Tcl and Tk

display a tcl/tk man page in a text box -------- set tt [exec man 3tk listbox 2>/dev/null] text .t -font {-size 12} .t insert end $tt pack .t focus .t bind . x exit ,,,

Proceedures Or Functions ‹↑›

No language can prosper with functions or proceedures. If there is no explicit return statement, then the result of the last command in the procedure is the returned value

determine the name of the current proceedure ------- proc Do {args} { puts "proc = [lindex [info level 0] 0]" } Do ,,,

Default Arguments Or Parameter Values ‹↑›

Note the double curly braces below. If they are not used then the Tcl interpreter thinks that the procedure has 2 arguments.

Global Variables And Procedures ‹↑›

Function Pointers ‹↑›

The name of a proceedure can be held in a variable. Which is not quite function pointers, but seems similar

a simple example of a function name in variable --------- proc addTax {x} {expr $x*1.16} set fn addTax; set amount 10 puts "$amount with tax is: [$fn $amount]" ,,,

A tcl array ? of pseudo function pointers ------ proc f(1) {} {puts hello} proc f(2) {} {puts world} proc f(3) {} {puts again} for {set i 1} {$i<=3} {incr i} {f($i)} ,,,

Maps ‹↑›

using a map function j ----- proc fn {x} {expr $x*1.16} set l1 {1 2 3 4} set l2 [map fn $l1] ,,,

Recursive Proceedures ‹↑›

the factorial function written recursively ------ proc fac x {expr {$x<2? 1: $x*[fac [incr x -1]]}} puts [fac 4] ,,,

Widget Procedures ‹↑›

Brent Welch uses an important technique in his book about tcl/tk. This is a procedure which takes an arbitrary number of arguments and returns a widget. This is a way to "extend" widgets, or a kind of non-object oriented inheritance.

The example below is like a masterclass in tcl/tk programming. Notice that the procedure returns a text area not a frame. It also takes care of laying out the scrolled text widget.

The eval command is important. It allows us to supply all the same options to the ScrollText widget as we can to the normal text widget. In this sense it is reminiscent of inheritance.

Libraries And Packages ‹↑›

The source command reads and evaluates all tcl commands in a file. This is a simple way to include a file containing procedures in the current script

load all tcl files in a dir --------- foreach script [glob lib/*.tcl] { source $script } ,,,

Running Scripts ‹↑›

We can also run a tk graphical script using tclsh as long as the line "require package Tk" is present. This has the great advantage on windows of writing puts statements to the console (which doesnt seem to happen with wish)

Useful Libraries ‹↑›

Ternary Operator ‹↑›

Control Flow ‹↑›

If Then Etc ‹↑›

an if then example ------- if { test1 } { body1 } elseif { test2 } { body2 } else { bodyn } ,,,

an if clause with a logical AND operator ------- set a 3; set b 4 if { $a>2 && $b>3 } { puts "a>2 and b>3" } ,,,

an if clause with a NOT operator ------- set a 3; set b 4 if { ![expr $a>6] } { puts "a is not > 6" } ,,,

testing equality ------- set a 3; set b 4 if { [expr {$a/1} ] == [expr {$b/double(1)}] } { puts "a==b" } else { puts "!=" } ,,,

Loops ‹↑›

For Counted Loop ‹↑›

Is there a language which doesnt have a foreach loop? Probably Lisp and Tcl/Tk may have been inspired by Lisp partly but it has a counted for loop.

a for loop -------- for {set i 0} {$i < 10} {incr i} { puts "I inside first loop: $i" }

a for loop using hexadecimal -------- for {set i 0} {$i < 0x100} {incr i} { puts "I : $i" } ,,,

While Loops ‹↑›

Foreach Loops ‹↑›

Input ‹↑›

Arithmetic And Mathematics In Tcl ‹↑›

do integer division and display the result ---- set a 21; set b 10 puts "$a/$b=[expr {$a/$b}]" ,,,

do decimal (non integer) division and display the result ---- set a 21; set b 10 puts "$a/$b=[expr $a/double($b)]" ,,,

some basic arithmetic using expr --------- set a 21; set b 10 set c [expr $a + $b] ,,,

The problem below is relevant when scaling images to fit into a screen or widget size. The ceil function can be used instead of a loop

find the least divisor of a number etc --------- set x 2345; set y 1024 for {set i 2} {$i < 1000} {incr i} { set q [expr {$x/$i}] if {$q < $y} { puts "$x/$i=$q < $y"; break } } ,,,

Subtraction ‹↑›

simple subtraction -------- set q 4 puts [expr {12-$q}] #puts [expr {12/double($q)}] ,,,

Double Or Decimal Numbers ‹↑›

double division -------- set q 4 puts [expr {12/$q}] puts [expr {12/double($q)}] ,,,

is a double the same as an integer -------- set q 4 if {[expr {12/$q}] == [expr {12/double($q)}]} { puts "yes 12/$q == 12/4.0" } ,,,

Integer Techniques ‹↑›

how ceil works ------- puts "ceil(2.1) = [expr {ceil(2.1)}]" puts "ceil(2.9) = [expr {ceil(2.9)}]" puts "ceil(2.0) = [expr {ceil(2.0)}]" puts "ceil(5/2.0) = [expr {ceil(5/2.0)}]" ,,,

use ceil to round up ------- set a 5; set b 2 puts "[expr {ceil($a/double($b))}]" ,,,

Math Functions ‹↑›

In the example below we place a new function into the 'mathfunc' namespace which allows us to use it easily with the expr command.

define a new math function and use it ------ proc tcl::mathfunc::calc {x y} { expr { ($x**2 - $y**2) / exp($x**2 + $y**2) } } puts [expr {calc(3,4)}] ,,,

Expr ‹↑›

The way to evaluate mathematical functions and operations in tcl/tk is to use the expr command

eg ---- if { [expr {1000/double(4)}] > [expr {200/double(5)}] } { puts yes } ,,,

Gotchas For Expr ‹↑›

If you forget a closing curly brace for and expr expression then tcl does not complain, but doesnt do what you want it to.

Random Numbers ‹↑›

generate 30 random numbers between 0 and 1 inclusive ----- for {set i 0} {$i < 30} {incr i} { puts "$i: [expr {rand()}]" } ,,,

The following maybe useful for doing random shuffles of lists using the lsort -command ...

generate 30 random numbers between -1 and 1 ----- for {set i 0} {$i < 30} {incr i} { puts "$i: [expr {rand()*2 - 1}]" } ,,,

generate 30 random numbers between 0 and 99 inclusive ----- for {set i 0} {$i < 30} {incr i} { puts "$i: [expr { int(100 * rand()) }]" } ,,,

generate 1 pseudo random number 0<n<10 using the clock ------ puts [expr {[clock microseconds] % 10}] ,,,

get a random element from a list --------- set ll {seed grain pebble book paper sheet} for {set i 0} {$i < 10} {incr i} { set f [lindex $ll [expr {[clock microseconds]%[llength $ll]}]] puts $f } ,,,

Powers Of Numbers ‹↑›

Modulus Arithmetic ‹↑›

do a modulus calculation and display the result ---- set a 21; set b 10 puts "$a % $b = [expr $a % $b]" ,,,

Pythagoras Theorem ‹↑›

Find the length of the hypotenuse of a rectangle ------- proc Hypot {x1 y1 x2 y2} { return [expr {sqrt(($x2-$x1)**2 + ($y2-$y1)**2)}] } puts "Length of Hypotenuse: [Hypot 0 0 3 4]" ,,,

use the hypot function ---- puts "Hypotenuse of 3,4 is [expr {hypot(3,4)}]" ,,,

Trigonometry ‹↑›

Comparisons ‹↑›

compare 2 numbers in tcl ----- set y 2; set x 1 if {$y > $x} { puts "y ($y) is greater than x ($x)" } ,,,

Geometry ‹↑›

Variables ‹↑›

Tcl/Tk does not have variable assignment syntax, so a=2 does not work. Use 'set' instead. In general tcl/tk has a very minimalist syntax.

Global Variables ‹↑›

Unicode ‹↑›

convert an integer to a unicode character ------ set value 0x2f72 set char [format %c $value] puts $char ,,,

print a list of kanji ------- for {set i 0x2F52} {$i < 0x2F62} {incr i} { puts [format %c $i] } ,,,

a list of kanji in a text box ------- text .t -font {-size 14} for {set i 0x2F00} {$i < 0x2FFF} {incr i} { .t insert end " [format %c $i] " } pack .t; focus .t; bind . x exit ,,,

a label with the rain kanji character -------- label .l -text "雨" -font {-size 22} pack .l -padx 20 -pady 20 bind . x exit ,,,

a label with the rain kanji character -------- set text [exec unicode rain] text .t -font {-size 14} .t insert end $text pack .t bind . x exit ,,,

display hebrew and cyrillic blocks ------- set text [exec unicode 0450..0520] puts $text ,,,

Kanji ‹↑›

Japanese writing, probably the hardest known to animal or beast deserves its own chapter. Modern tcl/tks can display all these characters in the tk widgets. hooray

display 1-5 stroke kanji with z/Z zooming -------- font create ff -size 18 option add *font ff pack [text .t]; .t insert end " Kanji with 1-5 strokes 一人入力二十八七九刀丁大上下子小口山三女土工士万川丸千夕亡干久己才寸弓手日中不引分水切心文内方公化月天木火止反元今予戸支少王区円片父五太欠友仏夫毛比牛氏六午犬尺仁出生立本付目外主用代打民正白世平半仕石市加収失末古北母台申圧四可未広庁弁布示必田処写号辺礼句去旧左刊他玉由司右令史札包以皮冬犯幼兄永氷功矢穴冊皿央合気行地会年自名当同先回成有全交色向死安任次団共多休好字早伝式在" bind . z { font conf ff -size [expr [font conf ff -size]+2] } bind . Z { font conf ff -size [expr [font conf ff -size]-2] } bind . x exit ,,,

random colour all 1-5 stroke kanji in labels -------- font create ff -size 34 option add *font ff proc Colour {} {format #%06x [expr {int(rand() * 0xFFFFFF)}]} set kk "一人入力二十八七九刀丁大上下子小口山三女土工士万川丸千夕亡干久己才寸弓手日中不引分水切心文内方公化月天木火止反元今予戸支少王区円片父五太欠友仏夫毛比牛氏六午犬尺仁出生立本付目外主用代打民正白世平半仕石市加収失末古北母台申圧四可未広庁弁布示必田処写号辺礼句去旧左刊他玉由司右令史札包以皮冬犯幼兄永氷功矢穴冊皿央合気行地会年自名当同先回成有全交色向死安任次団共多休好字早伝式在" set sixten "再曲老血両光肉西列米守百印存仮争件考仲衣吸毎各宅因羽虫灯危至耳糸州寺竹宇池舌灰兆羊后机見体言作身売社来車決何利足別形対返役初投近花局冷労私防声図応位住医角乱告余状走判改兵助低男折良町芸技児条赤完快否材我系求村究似束災弟囲序均志卵里君豆麦忘希困谷臣批孝貝努坂汽物学国取的事金者所実長定法性明直空受知和画表味官制夜放治苦命門店使居価雨念具例参東並歩育果青始服呼波非板林油固若券延版注効協底刻英委典河岸武供府周宝乳担易季毒京岩松舎届往承妻幸泣宙肥卒宗沿拡枚述牧垂拝忠刷泳招芽枝姉昔径妹前発食面重後風度点持海乗相品政神信思変保屋音送軍科指追計急退要飛室独草界限待南洋美活段約負客首巻建便派専省逆洗春茶単査星型栄背厚県昨故映係級染研則秋祖昼祝革奏紅皇砂城律迷紀炭看勇宣畑姿柱拾浅泉胃秒肺昭書家通高時流原員真連差特配病記消起格校料素紙党根速能院留残害造座案値容破殺帰降修師弱挙馬酒席航帯骨息射除財納夏借旅益個従笑宮将荷島梅庭純秘庫株脈展浴討候粉訓徒恩針倍胸孫倉勉朗耕桜俳俵班郡陛蚕理動産部務教転強"

regsub -all {\s+} $kk {} kk set ll [split $kk {}] puts "colouring [llength $ll] kanji" set ii 0 foreach k $ll { label .l$k -text $k -bg [Colour] grid .l$k -row [expr {$ii/20}] -column [expr {$ii%20}] incr ii } bind . z { font conf ff -size [expr [font conf ff -size]+2] } bind . Z { font conf ff -size [expr [font conf ff -size]-2] } bind . x exit ,,,

kanji in labels ------- set kanji [split [exec unicode 2F62.. ] { }] foreach k $kanji { catch { label .$k -text $k -font {-size 14} pack .$k } } bind . x exit ,,,

Fonts For Unicode Characters ‹↑›

--- pack [text .t] .t insert end "Japan \u65E5\u672C\n" .t insert end "Athens \u0391\u03B8\u03AE\u03BD\u03B1\u03B9" ,,,

Comments ‹↑›

These are preceded by the #. Notice that a ; semicolon is necessary after tcl/tk code and before a comment on the same line.

Strings ‹↑›

Comparing Strings ‹↑›

an easier way to check if a string is empty --- set val {} puts [expr {$val ne "" ? "not empty" : "empty"}] ,,,

using the funny 'ni' word ------ set a "tree"; set b "re" if { $a ni $b } { puts "no" } ,,,

Matching Strings ‹↑›

check if one string is contained in another, ignoring case --------- set a "re"; set b "TREE"; if {[string match -nocase *$a* $b]} { puts yes } ,,,

another (worse) way to check if 'tree' contains 're' ----- set a re; set b tree if {[string first $a $b] == -1} { puts no } ,,,

Concatenating Or Joining Strings ‹↑›

concatenate 2 strings onto the first -------- set a "abc"; set b "xyz"; set c "ABC" append a $b $c puts $a ,,,

a less efficient way to join strings ------ set x "abc"; set x "$x efg" puts $x ,,,

Formatted String Output ‹↑›

Scan ‹↑›

Scan extracts data from strings. It may be an alternative to regexp for parsing text data.

Substrings ‹↑›

delete upto the first instance of ':' --- set s "aa:bb" puts [string range $s [string first : $s] end] ,,,

delete up to the first occurrance of the character ':' ------ set s "data: tree" puts [lindex [split $s :] 1] ,,,

Splitting Strings ‹↑›

Splitting of strings can be done with regexp or split. Tcl 'split' has the staggering limitation that is can only split on a character (not on a string or regular expression). A workaround might be to use the power of awk in an exec and then process with tcl (or else use regexp -all)

get the last word of a sentence ----- puts [lindex [split "one two tree" " "] end] ,,,

split into words ------ set text "Some arbitrary text which might include \$ or {" set wordlist [regexp -inline -all {\S+} $text] for {set i 0} {$i < [llength $wordlist]} {incr i} { puts "$i: [lindex $wordlist $i]" } ,,,

The technique below almost works but doesnt get the last paragraph unless it ends with a blank line

" set wordlist [regexp -inline -all -- {.*?\n\s*\n} $text] for {set i 0} {$i < [llength $wordlist]} {incr i} { puts "$i: [lindex $wordlist $i]" } ,,,

set wordlist [regexp -inline -all -- {.*?\n\s*\n} $text] for {set i 0} {$i < [llength $wordlist]} {incr i} { puts "$i: [lindex $wordlist $i]" } ,,,

Substituting In Strings ‹↑›

get rid of the "<" and ">" characters ---- puts [string map {< {} > {}} "<lmn>"] ,,,

Length Of Strings ‹↑›

Interpolating In Strings ‹↑›

This is like the backticks or $(...) in the bash shell and it can be nested. This is a powerful feature of tcl which may be reminiscent of lisp...

Whitespace ‹↑›

Its interesting how often silly little bugs come down to tabs and spaces and \n \r etc

Regular Expressions ‹↑›

check if an email address has an @ etc ------- set email "bob at bigcorp" if { ![regexp {.+@.+} $email] } { puts "Your email address doesn't look valid." } ,,,

Submatches ‹↑›

A 'submatch' is a bracketed expression within a regular expression pattern. It is a handy way to extract only the data which you are interested in.

Above the variable $junk is the whole matched pattern and is not used. Sometimes -> is used, not sure why

Non Greedy Matching ‹↑›

Non greedy matching matches the shortest possible match instead of the longest. The '?' character is used to modify other regex special characters.

Lists And Regular Expressions ‹↑›

split some text into an array of words ------- set text "Some arbitrary text which might include \$ or {" set wordlist [regexp -inline -all -- {\S+} $text] puts $wordlist ,,,

Unicode Regexp Patterns ‹↑›

You can use 'character classes' such as [[:alpha:]] to match non latin alphabet characters.

Gotchas For Regular Expressions ‹↑›

If the pattern does not match the text then the match variable may be undefined and will throw and error if accessed.

Uppercase And Lowercase ‹↑›

Paragraph Matching ‹↑›

Lists ‹↑›

append an entire list to another ------ lappend ff {*}[glob *.jpg] puts [join $ff \n] ,,,

split a string into a list of characters ------- puts [lindex [split "a" {}] 0] puts [split "a" {}] ; # the same ,,,

Accessing Elements Of A List ‹↑›

get the 2nd element of a list ------- set ll {star moon rain wind earth} puts "Second Element is '[lindex $ll 1]'" ,,,

Tcl/Tk makes things easy, so we can use the special 'end' index to get the last element of a list. This is like [llength $list] - 1

get the last element of a list ------- set ll {star moon rain wind earth} puts "last Element is '[lindex $ll end]'" ,,,

Random Elements Of A List ‹↑›

get a random element of a list ------- set ll {star moon rain wind earth} puts "Random element: [lindex $ll [expr { int([llength $ll] * rand()) }]]" ,,,

Strangely there are a suspicious number of repeated elements when I run the code below

print 20 random elements from a list ------- expr {srand([clock clicks])} set ll {star moon rain wind earth water sea air} for {set i 0} {$i < 20} {incr i} puts "$i: [lindex $ll [expr { int([llength $ll] * rand()) }]]" } ,,,

Lassign ‹↑›

Deleting Elements ‹↑›

delete the 3rd element from a list ----- set ll {a b c d} set ll [lreplace $ll 2 2] puts $ll ,,,

delete an element by value ------- set ll {a b c d} set idx [lsearch $ll "b"] set ll [lreplace $ll $idx $idx] puts $ll ,,,

Joining Lists ‹↑›

Constructing Lists ‹↑›

create a list with split ------- set group_source [ split $itext [ regexp {^$} $itext ] ] ,,,

Filtering Lists ‹↑›

get a list of unique words used in some text --------- set text " and if we have. and. if have:when is all is sleep" set words [split $text " \n\t.:"] set words [lsort -unique -dict $words] puts [join $words \n] ,,,

Mapping Lists ‹↑›

transform a list ---- set nn {a b c d e f} set mm [lmap s $nn { set s "$s:" }] puts $mm ,,,

Sorting Lists ‹↑›

sort a list in dictionary (alphabetical ?) order ----- set ww [list zz A a c ee dd ff] set ww [lsort -dict $ww] puts [join $ww \n] ,,,

The code below is definitely not the most efficient way to do this, but demonstrates the use of the -command option to lsort

reverse the order of a list ----- proc Reverse {a b} { return 1 } set ww [list zz A a c ee dd ff] set ww [lsort -command Reverse $ww] puts [join $ww \n] ,,,

randomly sort a list, or shuffle it ----- proc Shuf {x y} { expr {[clock micros]%3 - 1} } set ww [list a b c d e f g h i j] set ww [lsort -command Shuf $ww] puts [join $ww \n] ,,,

trying to use rand to shuffle ----- proc Shuf {a b} { # rand is not working ?? #return [expr {rand()*2 - 1}] return [expr {([clock microseconds]%3) - 1 }] } set ww [list a b c d e f g h i j] set ww [lsort -command Shuf $ww] puts [join $ww \n] ,,,

Iterating Lists ‹↑›

iterate through a list using an index number ------ set wordlist [list a b c dd ee ff] for {set i 0} {$i < [llength $wordlist]} {incr i} { puts "$i: [lindex $wordlist $i]" } ,,,

Arrays ‹↑›

The word 'array' in the context of tcl/tk means 'associative array' or what is sometimes called in other languages a 'hash'. An array is like a dictionary where each word is associated with a value (eg a definition)

Creating Arrays ‹↑›

create and display an array ------ array set n {size big colour blue} puts [array get n] ,,,

Accessing Elements ‹↑›

Analysing Arrays ‹↑›

Iterating Arrays ‹↑›

Dictionarys ‹↑›

Dictionaries are a new data structure introduced in tcl/tk 8.5 Not sure how they work, but look promising.

Email ‹↑›

Lets keep this simple and just use mutt (but you have to install and configure it etc- not entirely painfree)jfk

sort the lines of the muttrc aliases ------- set aa [exec sed -n "/^alias /s/alias *//p" $env(HOME)/.muttrc] puts [join [lsort [split $aa \n]] \n] ,,,

select lines from the muttrc aliases using a filter function ------- proc Filter { ll pattern } { set rr {} foreach item $ll { if {[string match -nocase *$pattern* $item]} { lappend rr $item } } return $rr } set aa [exec sed -n "/^alias /s/alias *//p" $env(HOME)/.muttrc] set ss [Filter [split $aa \n] "ama"] puts [join $ss \n] ,,,

Mutt And Tcl Tk ‹↑›

A simple way to send email with tcl/tk is to use the mutt terminal mail client. You need to configure mutt first to be able to find and authenticate to your email server.

To do, a subject line that appears and disappears. Font zooming in the message area. (what is this small screen big font bug??). Reverse colour keystroke. Search email addresses. Show images in email addresses An attachment box keystroke...

Using big fonts on a small screen in a text box seems to create packing problems (widgets after the text widget dont display)

Smtp ‹↑›

sending mail is usually done with this protocol, but why not just use mutt? I suppose you will have to connect to the smtp server with tls and a login.

set rcpts [open email-list.txt] set files [lsort [glob *.JPG]] set text {Some of the pictures got mixed up} append text {Let's try this again.}

# create an image and text set imageT [mime::initialize -canonical \ "image/jpg; name=\"$this_image\"" -file $this_image] set textT [mime::initialize -canonical text/plain -string $text]

set multiT [ mime::initialize -canonical multipart/mixed -parts [ list $imageT $textT]]

# send it to some friends puts "Sending to $rcpt: $this_image" smtp::sendmessage $multiT \ -header [list From {Juliane Mello <jmello@usu>}] \ -header [list To $rcpt] \ -header [list Subject Ooops!] incr i } ,,,

Imap ‹↑›

consider using offlineimap with tcl/tk. This way you always have an up-to-date local copy of you email.

tips to use the imap4 code with ssl ------ package require tls ; # must be loaded for TLS/SSL set ::imap4::use_ssl 1 ; # request a secure connection set chan [::imap4::open $server] ,,,

The code below says "sslv3 alert handshake failure" This may have something to do with the 'poodle' security prob with sslv3. So ...

search for all message > 4K which have been seen ------- ::imap4::search $chan larger 4000 seen puts "Found messages: [::imap4::mboxinfo $chan found]" Found messages: 1 3 6 7 8 9 13 14 15 19 20 ,,,,

Searching Imap Mail ‹↑›

The following is a simple inbox search. The results should be displayed in a listbox. Also it is slow when a lot of results are returned. So it would be better to use and offline maildir

search by subject ------ package require tls package require imap4 option add *font "Courier 14" wm attributes . -zoomed 1

entry .pass -textvar pass; label .l -textvar ii -justify left -padx 50 -pady 20 text .t -width 70 -height 30 entry .search -textvar what pack .l set ii "Press c to connect"

bindtags .pass [list all Entry .pass] bindtags .search [list all Entry .search] bind . x exit bind . c { set ii "Enter Password" pack forget .search; pack .pass; focus .pass } bind . / { set ii "Enter search term" pack forget .pass; pack forget .t; pack .search; focus .search } bind .pass <Return> { set ii "Connecting..." set chan [::imap4::open "mail.messagingengine.com"] if {[catch {::imap4::login $chan mjbishop@fastmail.fm $pass} result]} { set ii "Incorrect password \n $result" } else { ::imap4::select $chan INBOX set total [::imap4::mboxinfo $chan exists] set ii "Connected: $total messages in inbox" } pack forget .pass; focus . } bind .search <Return> { if {$what eq ""} { pack forget .search; focus . } set ii "Searching $total mail subject lines for '$what'" ::imap4::search $chan subject $what set ll [::imap4::mboxinfo $chan found] set ii "Found [llength $ll] emails matching '$what' in subject" set fields {from: subject: date: } .t delete 1.0 end foreach id $ll { set head [lindex [::imap4::fetch $chan $id:$id -inline {*}$fields] 0] .t insert end "[join $head |] \n" } pack .t pack forget .search; focus . #catch {::imap4::close $chan} }

find out how many mails are in a mail folder ------ package require tls package require imap4 option add *font "Times 14"

entry .e -textvar pass; label .l -textvar mails pack .e .l; focus .e bind .e <Return> { set chan [::imap4::open "mail.messagingengine.com"] ::imap4::login $chan mjbishop@fastmail.fm $pass ::imap4::select $chan INBOX set mails "[::imap4::mboxinfo $chan exists] mails in INBOX" catch {::imap4::close $chan} }

Deleting Mail ‹↑›

mark a message or messages as deleted and then really delete -------- ::imap4::store $chan $start_msgid:$end_msgid +FLAGS "Deleted" ::imap4::expunge chan ,,,

Web ‹↑›

package require http set token [http::geturl http://www.beedub.com/index.html] puts [http::data $token] ,,,

package require http http::config -proxyhost eg.com -proxyport 8080 set token [http::geturl http://www.beedub.com/index.html] puts [http::data $token] ,,,

Http Etc ‹↑›

Curl is a comprehensive wget like program for retrieving urls in the most convoluted of circumstances. So it may well be a boon that tcl has bindings for its library...

Stdin And Stdout ‹↑›

Printing Or Displaying Text On Stdout ‹↑›

colourfull text with ansi escape sequences ----- set yy {\x1B[0;33m} set nn {\x1B[0m} puts "\033\[01;31m $yy Colour full" ,,,

Reading Stdin ‹↑›

Internationalisation ‹↑›

message catalog eg ------ package require msgcat puts "hello" # standard puts [msgcat::mc "hello"] # with a message catalog ,,,

Folders And Directories ‹↑›

Files ‹↑›

Globbing ‹↑›

Glob returns an error if nothing matches which needs to be handled or else use -nocomplain .

show all txt files in the current directory: --------- puts [join [glob *.txt] \n] ,,,

use multiple patterns with glob ---- set f ~/Pictures set ll [glob -nocomplain -directory "[file dirname $f]" *.jpg *.JPG] puts $ll ,,,

The following uses the nifty eval trick, which one is not likely to stumble across by trial and error

put the multiple glob patterns in a list

    set ss [list *.jpg *.png *.gif]
    set ll [eval {glob -directory $env(HOME)/} $ss]
    foreach f $ll { puts $f }
    puts "found [llength $ll] text files"

print the users home folder

 puts $env(HOME)

other tricks to get home folders --- puts [exec find [glob -dir /home -type d *]/Pictures -iname '\*'] catch {exec find [glob -dir /home -type d *]/Pictures -iname '**'} result puts $result ,,,

The tilde "~" does not expand when it is included as part of a file name, but the "glob" command does seem to understand it.

find all the txt files in the user's home directory

 puts [glob -directory ~ *.txt]

find all the txt files in the user's home directory

 puts [exec {echo $HOME}]

find all subdirectories of the current directory

 glob -type d *

find all home folders

 puts [glob -directory /home/ -type d *]

 puts [glob -dir /home -type d *]

create a combobox with the names of subfolders as values

 pack [ttk::combobox .c -textvariable state -values [glob -type d *]]

find all files whose name contains an "a", a "b" or "cde"

 glob -type f *{a,b,cde}*

Finding Files ‹↑›

maybe use tclx recursive_glob

fileutil::find is this recursive

a one folder level recursive jpg file search

    set ll [glob -dir $env(HOME)/Pictures *.{jpg,JPG} */*.{jpg,JPG}]
    foreach f $ll { puts $f }
    puts "found [llength $ll] jpegs"

a 2 folder level recursive txt file search

    set ll [glob -dir $env(HOME) *.txt */*.txt */*/*.txt]
    foreach f $ll { puts $f }
    puts "found [llength $ll] text files"

put the file search patterns in a list

    set base $env(HOME)
    set ss [list *.txt */*.txt */*/*.txt]
    set ll [eval {glob -nocomplain -type {f r} -directory $base} $ss]
    # foreach f $ll { puts $f }
    puts "found [llength $ll] text files"

find lots of jpegs without recursion

    set base $env(HOME)
    set ss [list *.{jpg,JPG} */*.{jpg,JPG} */*/*.{jpg,JPG} \
      */*/*/*.{jpg,JPG} */*/*/*/*.{jpg,JPG} */*/*/*/*.{jpg,JPG}]
    set t1 [clock millis]
    set ll [eval {glob -nocomplain -type {f r} -directory $base} $ss]
    set t2 [clock millis]
    puts "found [llength $ll] jpg files in [expr $t2-$t1] ms"

Trying to glob "/root/" will produce a permissions error. So that error needs to be caught, otherwise no results are given.

globbing the root

    set ll [glob -directory / *]
    foreach f $ll { puts $f }

The code below also fails when there are permissions problems if there is no {d r} directory and readable, or {f r} file and readable.

The following 2 lines are not equivalent. In fact the first sometimes finds more files than the second, strange as that may seem. Also the first seems nearly 25% faster. But maybe there are cross platform problems with the first... I am not sure

 lappend ff {*}[glob -nocomplain -type {f r} -dir $baseDir $pattern]

 lappend ff {*}[glob -nocomplain -type {f r} [file join $baseDir $pattern]]

find files matching a pattern

   proc findFiles { baseDir pattern } {
     set dirs [glob -nocomplain -type {d r} -dir $baseDir *]
     set ff {}
     foreach dir $dirs {
       lappend ff {*}[findFiles $dir $pattern]
     }
     lappend ff {*}[glob -nocomplain -type {f r} -dir $baseDir $pattern]
     return $ff
   }
   set t1 [clock milliseconds]
   set ll [findFiles $env(HOME) "*.{jpg,JPG}" ]
   set t2 [clock milliseconds]
   puts "Found [llength $ll] files in [expr $t2-$t1] ms"
  ,,,,

  * find files with file join, but this is slower 
   proc findFiles { baseDir pattern } {
     set dirs [glob -nocomplain -type {d r} [file join $baseDir *]]
     set ff {}
     foreach dir $dirs {
       lappend ff {*}[findFiles $dir $pattern]
     }
     lappend ff {*}[glob -nocomplain -type {f r} [file join $baseDir $pattern]]
     return $ff
   }
   set t1 [clock milliseconds]
   set ll [findFiles $env(HOME) "*.jpg" ]
   set t2 [clock milliseconds]
   #puts [ join $ll \n ]
   puts "Found [llength $ll] files in [expr $t2-$t1] ms"
  ,,,,

  * find files bigger than a certain size. 
   proc findFiles { baseDir size } {
     set dirs [glob -nocomplain -type {d r} -dir $baseDir *]
     set ff {}
     foreach dir $dirs {
       lappend ff {*}[findFiles $dir $size]
     }
     set gg [glob -nocomplain -type {f r} -dir $baseDir *]
     foreach f $gg {
       if {[file size $f] > $size} { 
         lappend ff $f 
       }
     }
     return $ff
   }
   set t1 [clock milliseconds]
   set ll [findFiles $env(HOME) 60000000 ]
   set t2 [clock milliseconds]
   puts [join $ll \n]
   puts "Found [llength $ll] files in [expr $t2-$t1] ms"
  ,,,,

 The code below is an almost useful app.

 * show big files in a listbox and delete on 'd' press (careful!) 
 ---------
   proc findFiles { baseDir size } {
     set dirs [glob -nocomplain -type {d r} -dir $baseDir *]
     set ff {}
     foreach dir $dirs {
       lappend ff {*}[findFiles $dir $size]
     }
     set gg [glob -nocomplain -type {f r} -dir $baseDir *]
     foreach f $gg {
       if {[file size $f] > $size} { 
         set ssize [file size $f]
         if {$ssize > 1000000000} { 
           set ssize "[expr $ssize/1000000000]G" 
         } elseif {$ssize > 1000000} { 
           set ssize "[expr $ssize/1000000]M" 
         } elseif {$ssize > 1000} { 
           set ssize "[expr $ssize/1000]K" }
         lappend ff "$ssize $f"
       }
     }
     return $ff
   }

   wm attributes . -zoomed 1
   set limit 100000000
   set ll [findFiles $env(HOME) $limit]
   wm title . "Found [llength $ll] files bigger than $limit"
   listbox .lb -listvar ll -width 60 -font {-size 14}
   pack .lb -fill both -expand true; focus .lb
   bind .lb j { event generate .lb <Down> }
   bind .lb k { event generate .lb <Up> }
   bind .lb m { 
     wm title . "finding big files on media, please wait ..."
     set ll {}
     update idletasks
     set ll [findFiles /media/ 100000000 ]
     wm title . "Found [llength $ll] files bigger than $limit"
   }
   bind .lb d { 
     #puts [.lb get [.lb curselection]]
     set index [.lb curselection]
     set f [lindex [split [.lb get [.lb curselection]]] 1]
     puts $f
     set ll [lreplace $ll $index $index]
     file delete $f
     wm title . "Deleted $f, hope thats ok!"
   }
   bind .lb h { 
     puts "
       j - down
       k - up
       d - delete current file
       m - show media files
       h - show this help
       "
   }
   bind .lb x exit


 a more verbose recursive file find
   proc findFiles { basedir pattern } {
   # add a separator to folder 
     set basedir \
       [string trimright [file join [file normalize $basedir] { }]]
     set fileList {}
   
     # {f r} only readable normal files
     foreach fileName [glob -nocomplain -type {f r} -path $basedir $pattern] {
       lappend fileList $fileName
     }
     foreach dirName [glob -nocomplain -type {d  r} -path $basedir *] {
       set subDirList [findFiles $dirName $pattern]
       if { [llength $subDirList] > 0 } {
         foreach subDirFile $subDirList {
           lappend fileList $subDirFile
         }
       }
     }
     return $fileList
   }
   set ll [findFiles $env(HOME) "*.txt" ]
   puts [ join $ll \n ]
   puts "Found [llength $ll] files"


But this produced errors when the folder is
unreadable, and it also seems slow compared to
searches above

 find files using tcllibs "fileutil"
   package require fileutil
   set basepath $env(HOME)
   foreach file [fileutil::findByPattern $basepath *.tcl] {
     puts $file
   }
  ,,,,

  This is not working below. 

  * brent welchs recursive findfile
  ------
    proc Findfile { startDir namePat } {
      set pwd [pwd]
      if {[catch {cd $startDir} err]} {
        puts stderr $err
        return
      }
      foreach match [glob -nocomplain -- $namePat] {
        puts stdout [file join $startDir $match]
      }
      foreach file {[glob -nocomplain *]} {
        puts $file
        if [file isdirectory $file] {
          FindFile [file join $startDir $file] $namePat
        }
      }
      cd $pwd
    }
    Findfile /home/arjuna/Pictures *.JPG  




Filenames ‹↑›

 return the name of the file without folder
-----
set f "/usr/share/dict/words.en.txt"
puts "[file tail $f]"
,,,

 turn a relative file name into an absolute one
----
set fn ../bob
set fn [file join [pwd] $fn]
puts $fn
,,,

 get the file name extension
-----
set f "/usr/share/dict/words.en.txt"
puts "suffix of $f is [file extension $f]"
,,,

 file name with no extension
-----
set f "/usr/share/dict/words.en.txt"
puts "rootname of $f is [file rootname [file tail $f]]"
,,,



Tildes ‹↑›

expanding the ~ into the home folder can cause problems.
file open seems to do it well.



Encodings Of Text Files ‹↑›

 show all encodings known to tcl/tk
 puts [lsort [encoding names]]

 read a text file in a russian encoding
-----
set in [open text.russian]
fconfigure $in -encoding iso8859-7
,,,




Reading Files ‹↑›

 read the entire contents of a text file
    set f [open "/usr/share/dict/words" r]
    set s [read $f]; puts $s
    close $f


 the most succinct, but then you cant close the file pointer
    puts [read [open "~/Pictures/fav.txt" r]]


 another way to read a file on unix (but doesnt expand '~' tildes)
 set data [exec cat $filename]

 read 2 text files at once on unix
 set data [exec cat $file1 $file2]

 compare performance of 'exec cat' vs 'open/read'
---------
set f /usr/share/dict/words
set a [clock milliseconds]
set data [exec cat $f $f $f]
set b [clock milliseconds]
puts "exec cat time: [expr $b-$a] ms"
set a [clock milliseconds]
set p [open $f r]; set data [read $p]; close $p
set p [open $f r]; append data [read $p]; close $p
set p [open $f r]; append data [read $p]; close $p
set b [clock milliseconds]
puts "open/read time: [expr $b-$a] ms"
,,,

Linux seems to buffer the contents of $f above after the
first 'exec cat' but the first time it is about twice as slow

 read the entire contents of a text file
    set f [open "~/sf/htdocs/books/tcl/tcl-book.txt" r]
    set s [read $f] 
    puts $s
    close $f


 read a file a line at a time
-------
set fp [open $some_file]
while {-1 != [gets $fp line]} {
puts "The current line is '$line'."
}
,,,

The code below will fail if the script has been piped to tclsh or
wish (eg cat s.tcl | tclsh). In this case the value of $argv0 will
be 'tclsh' or 'wish'

 read the contents of the script file itself
    puts "The name of this script is $argv0"
    set f [open $argv0 r]
    set s [read $f] 
    close $f




File Checks ‹↑›

 an entry box which turns red if invalid file name
-------
entry .e -textvar file -width 50 -validate all -validatecommand {isFile %P .e}
button .b -text "Browse..." -command {set file [tk_getOpenFile]}
pack .e .b
proc isFile {f w} {
if { [file exists $f] && [file isfile $f] } {
$w configure -fg black
} else {
$w configure -fg red
}
return 1
};
,,,




Writing Text Files ‹↑›

http://wiki.tcl.tk/928
a good tk text example, with opening saving etc

Also use 'flush' to force writing of data.

 write one line of text to a text file
------
set data "Written by tcl.\n"
set filename "test.txt"
set f [open $filename "w"]
puts -nonewline $f $data
close $f
,,,

In the above closing the file $f causes the data to
be written straight away.

Below the 'w' event is activated even when the focus is
in the text box. which is not really what we want.

 write text to a file from a text box
------
pack [text .t]; focus .t
bind . w {
set data [.t get 1.0 {end -1c}]
set f [open "test.txt" w]
puts -nonewline $f $data
close $f
}
bind . x exit
,,,




Time And Date ‹↑›

clock scan - parse a free string date including '1 day ago'
clock clicks - time code

 print todays date in the format 'Friday, the 14 of August 2015'
-----
set now [clock seconds]
puts [clock format $now -format {Today is: %A, the %d of %B %Y}]
,,,

 convert 'today' into a formatted date such as 'Friday, 14 August 2015'
-----
set d [clock scan "today"]
puts [clock format $d -format {Date: %A, %d %B %Y}]
,,,

 check if a date is today
-----
set d [clock format [clock scan "today"] -format {%d%B%Y}]
puts $d
set e [clock format [clock scan "15aug2015"] -format {%d%B%Y}]
puts $e
,,,

 check if a date is today , another way to do it
-----
#set now [clock seconds]
set now [clock sec]
set d [clock format $now -format {%d%B%Y}]
puts $d
set e [clock format [clock scan "15aug2015"] -format {%d%B%Y}]
puts $e
,,,

 test if a string represents todays date
---
set date "15 aug 2016"
if { [string equal \
"[clock format [clock scan "today"] -format {%d%B%Y}]" \
"[clock format [clock scan $date] -format {%d%B%Y}]" ]} {
puts yes
} else { puts no }
,,,

 print the current time in hours minutes and seconds
------
puts "The time is: [clock format [clock seconds] -format %H:%M:%S]"
,,,

The 'catch' phrase below stops the application from
throwing an error when a bad date string is typed

 turn values like 'tomorrow' into actual dates with clock scan
---------
label .info \
-text {Type a text date like 'tomorrow' etc, esc=exit}
label .l -textvar tm -font {-size 20}
entry .e -width 40 -textvar s -font {-size 20}
pack .info .e .l; focus .e
bind .e <Return> {
set tm "'$s' is [clock format [clock scan $s]]"
set s {}
}
bind . <Escape> {exit}
,,,



Timezones ‹↑›

Another thorny issue are relative times and time zones.
The complications are endless.

 find out what time it is in new york right now
-------
set t [clock seconds]
puts [clock format $t -timezone :America/New_York]
,,,



Arithmetic Of Times And Dates ‹↑›

It is often good to be able to add and subtract
hours/minutes/days etc from a calendar time. This is
easy with clock add

 clock add time unit keywords
 seconds, minutes, hours, days, weeks, months, or years,

 find the date 2 weeks ago
--------
set a [clock seconds]
set b [clock add $a -2 weeks]
# clock add $a -2 w  - the same
puts "Two weeks ago: [clock format $b]"

,,,

date and time arithmetic can also be done with the 'clock scan' function

 print yesterdays date
---------
puts [clock format [clock scan "1 day ago"]]
puts [clock format [clock scan "-1 day"]]  # the same
,,,

keywords with clock scan:
year, month, fortnight, week, day, hour, minute, second
tomorrow, yesterday, today, now, last, this, next ago

 date 2 weeks before yesterday, gives strange results
---------
puts [clock format [clock scan "yesterday 2 fortnight ago"]]
puts [clock format [clock scan "2 fortnight ago"]]
,,,

 one week before the 11th of july
----
puts [clock format [clock scan "11 july -1 week"]]
,,,



Performance Of Code ‹↑›

Performance of code can be measured in milliseconds.

 measure elapsed time
--------
set a [clock milliseconds]
after 500
set b [clock milliseconds]
puts "elapsed: [expr $b - $a] ms"
,,,



Introspection ‹↑›

What does a language or program know about itself? Or pretend to know


 show info
 puts [info args clock]

 show all tcl/tk commands which have 'cl' in their name
 puts [info commands *cl*]

 show all built-in tcl/tk commands sorted alphabetically
 puts [lsort -dictionary [info commands]]

 list all built-in math functions
 puts [lsort -dictionary [info functions]]

 show the folder where the script is running
 puts [file dirname [info script]]

The above may just print '.' which is not helpful

 give a bad option to a command to get a list of valid options
 string -abc

The code below works by parsing the tcl/tk error message from a
bad option, deleting the 1st part of the message and then splitting
the options into a list.

 display a list of options to a command in a listbox
-----
catch {string -junk} result
set options [string range [lindex [split $result :] 1] 9 end]
set oo [split $options ,]
pack [listbox .l -listvar oo -font {-size 16}]
,,,



Widget Introspection ‹↑›

cget

Widgets dont engage in philosophy but they do have some kind of
self-knowledge if we are happy to accept that sophistry.

".widget configure" or an abbreviation thereof, returns a list  with all
possible configuration options and their values. This is invaluable. Mainly
we are interested in the indices 0,3,4 of this list

 display all possible config options of a listbox
-----
listbox .lb -font {-size 14}
pack .lb
foreach item [.lb config] {
.lb insert end "[lindex $item 0]"
}
bind . x exit
,,,

 display config options and their values
-----
wm attributes . -zoomed 1
listbox .lb -font {-size 14}
pack .lb -fill both
foreach item [.lb config] {
.lb insert end \
"[lindex $item 0]=[lindex $item 3] [lindex $item 4]"
}
bind . x exit
,,,



Threads ‹↑›

 use fileevent to open a thread on a long running process
   set $f [open "|find . -name '*big*'" r]
   pack [text .t]
   fileevent $f readable { .t insert end [gets $f]}


 update a label once per second (but seems slower)
   proc tick {} {
     global ss; incr ss
     after 1000 [list after 1000 tick]
   }
   set ss 0
   pack [label .l -textvar ss -font {-size 20} -padx 20]
   tick; puts "After tick"


 use 'after' to update gui in event loop
   proc doOneStep {} {
     if {[::my_calc::one_step]} {
       after idle [list after 0 doOneStep]
     }
   }
   doOneStep




Fileevents ‹↑›

The fileevent command is a powerful way to process data a bit
at a time from a pipe without blocking your application.

 a simple fileevent with pipe example
   set pipe [open "|some command"]
   fileevent $pipe readable [list Reader $pipe]
   proc Reader { pipe } {
     if [eof $pipe] {
       catch {close $pipe}
       return
     }
     gets $pipe line
     # Process one line
   }
   


Perhaps the "&| cat" trick below redirects standard error, but I
am not sure.

 without the &| cat seems to also work
  if [catch {open "|locate *.jpg"} input] {

 read from a long running process and print results
----------
if [catch {open "|locate *.jpg &| cat"} input] {
puts "Error: \n $input"
} else { fileevent $input readable Log }
proc Log {} {
global input
if [eof $input] {
catch {close $input}
} else {
gets $input line
puts $line
}
}
bind . s {
global input
catch {close $input}
puts "process stopped!"
}
bind . x { exit }
,,,

In the code below, using "update idletasks" after every element is
appending to the listbox works, but... it is really slow. A solution
would be to only update the display every hundredth time etc. That
is better but still twice as slow as not updating at all.

 update a listbox with the results from a long running process
----------
wm attributes . -zoomed 1
set count 0
set message "Finding Jpegs: $count"
label .l -textvar message
listbox .lb -width 40 -height 40
pack .l .lb -side top -fill x -expand true
if [catch {open "|locate *.jpg &| cat"} input] {
puts "Error: \n $input"
} else { fileevent $input readable Log }

proc Log {} {
global input count .lb .l message
if [eof $input] {
catch {close $input}
} else {
gets $input line
.lb insert end $line
.lb see end
incr count 1
set message "Jpegs: $count"
# using the following is slow

file tools
glob - returns a list of file names

# update idletasks } } } bind . s { global input message count catch {close $input} set message "Process stopped! Found $count Jpegs" } bind . x { exit } ,,,

Vwait ‹↑›

Vwait allows us to implement what are called sentry, or flag variables in threaded programming.

wait for a variable to be set ------- set x 0 after 500 {set x 1} vwait x ,,,

Widget Libraries ‹↑›

gnocl- gtk style widgets for tcl/tk The gnocl widgets are not compatible, option for option with the standard Tk widgets.

Blt ‹↑›

By George Howlett. Includes large data graph widget tabbed notebook, treeview, transparent busy widget with watch cursor. C based www.sourceforge.net/projects/blt

Tix ‹↑›

infrastructure for creating new widgets. Balloon help, tabbed windows, paned window and heirarchy browser. C based and compound. tix.sf.net

install the tix widgets

 sudo apt-get install tix

Tix contains lots of good widgets, including a 'balloon help' (also known as 'tool tips')

use the tix widget library ------- package require Tix ,,,

Incr Tk ‹↑›

[incr Tk] and [incr Widgets] create compound widgets with [incr Tcl] object system. Lots of widgets. Labelled entry, html display.

Book: [incr Tcl] from the Ground Up incrtcl.sf.net

Bwidgets ‹↑›

Tcl based. Tabbed notebook, combobox, hierarchy browser. www.sf.net/projects/tcllib

Tktable ‹↑›

spreadsheet like widget. www.sf.net/projects/tktable.

Widgets ‹↑›

Widget is the general name given to different types of components in the graphical system. Examples include frames, entry boxes, listboxes, dialogs etc

The code below demostrates the useful technique of returning a widget from a proceedure.

return a listbox widget widget from a function --------- proc NewListbox {f args} { frame $f listbox $f.list eval {$f.list configure} $args pack $f.list; return $f.list } set l [NewListbox .f -listvariable fonts] pack .f -expand yes -fill both set fonts [lsort [font families]] bind . x exit ,,,

Windows ‹↑›

set the title of a window

 wm title . "New Title"

get the size and position of the main window

 update; puts [wm geometry .]

display a window with the title hello

 echo 'wm title . "hello"' | wish

destroy all widgets except the main window

 eval destroy [winfo children .]

show a button

    wm title . "hello"
    button .b -text push -command {exit}
    pack .b

Resizing Windows And Widgets ‹↑›

We seem to use the <Configure> event to grab window and widget resizes.

display widget sizes --------- label .l -text Hello -font {-size 16}; pack .l -fill x tkwait visibility .l .l config -text "label dimensions: [winfo width .l]w x [winfo height .l]h px" bind . <Configure> { .l config -text \ "label dimensions: [winfo width .l]w x [winfo height .l]h px" } ,,,

display widget sizes using geometry --------- label .l -text Hello -font {-size 16}; pack .l -fill x tkwait visibility .l .l config -text "label geometry: [winfo geometry .l]" bind . <Configure> { .l config -text "label geometry: [winfo geometry .l]" } ,,,

Dimensions Of Windows And Widgets ‹↑›

Widgets are sometimes referred to as 'windows' because they are usually displayed in one, or have one, ...

create a top level window 400px wide by 300 high ------ wm geometry . 400x300 ,,,

In the code below, we have to wait until the window is actually displayed or else the sizes with be reported as 1x1

wait for the visibility of the widget .tk

 tkwait visibility .t

wait for a window to appear before computing size

    label .l -textvar size -font {-size 12}
    pack .l -fill x -expand true
    tkwait visibility .l
    set size "label size=[winfo width .l]w x [winfo height .l]h px"
    bind . x exit

screen dimensions winfo screenwidth winfo screenheight

see how much space we have on the screen

    wm attributes . -fullscreen true
    label .l -text "screen width=[winfo screenwidth .] screen height=[winfo screenheight .]"
    pack .l -fill x 
    bind . x exit

Full Screen ‹↑›

a full screen window (tk 8.5)

    wm attributes . -fullscreen 1
    button .b -text push -command {exit} -font {-size 30}
    pack .b

get the pixel dimensions of the toplevel window

    tk_bisque
    wm attributes . -fullscreen true
    pack [label .l -textvar tt]
    tkwait visibility .
    set tt "window: width=[winfo width .], height=[winfo height .]"
    bind . x exit

a full screen window (tk 8.5) with browny colours

    tk_bisque
    toplevel .foo
    wm attributes .foo -fullscreen 1
    pack [button .b -text push -command {exit}]

Visibility Of Windows And Widgets ‹↑›

The technique below can be used to create a dynamic interface which adapts to the context of the application.

check if a widget is visible (mapped) and swap it if so ------- label .l1 -text {first label} label .l2 -text {2nd label} pack .l1 bind . s { if {[winfo ismapped .l1]} { pack forget .l1; pack .l2 } else { pack forget .l2; pack .l1 } } ,,,

Minimized Windows ‹↑›

iconify when escape is pressed --------- button .b -text push -command {exit} -font {-size 20} pack .b bind . <KeyPress-Escape> "wm iconify ." ,,,

Maximised Windows ‹↑›

a maximized window

    wm attributes . -zoomed 1
    button .b -text push -command {exit} -font {-size 30}
    pack .b

Window Colours ‹↑›

In the example below, the background colour for the label is not affected by the main window bg colour.

change background colour for the main window ------ . configure -borderwidth 20 -bg black pack [label .l -text hello] ,,,

Dialog Boxes ‹↑›

A dialog box is a little window that pops up in order to annoy the user by asking for information.

display a message box when a button is pressed

   button .btn -text "press me" -command {
     tk_messageBox -message "Button was pressed" }
   pack .btn -padx 20 -pady 20

display a message box when a button is pressed

   button .btn -text "press me" -command {
     tk_messageBox -message "Button was pressed" }
   pack .btn -padx 20 -pady 20

display an error message box when a button is pressed

   button .btn -text "press me" -command {
     tk_messageBox -icon error -message "Button was pressed" \
       -title "some problem" -type abortretryignore
     }
   pack .btn -padx 20 -pady 20

display a color chooser dialog when a button is pressed

   button .btn -text "Choose a Colour" -command {
     tk_chooseColor -initialcolor cyan1 -title "Which Colour"
   }
   pack .btn -padx 20 -pady 20

a folder chooser

   button .btn -text "Choose a Folder" -command {
     tk_chooseDirectory -initialdir /home/ -title "which folder"
   }
   pack .btn -padx 20 -pady 20

a dialog to open only '.gif' files

   set typelist {
     {"GIF Image" {".gif"}} {"GIF Image" {} {"GIFF"}}}
   button .btn -text "Choose a file" -command {
     tk_getOpenFile -filetypes $typelist
   }
   pack .btn -padx 20 -pady 20

a dialog to open only '.txt' files and display which was chosen

   set typelist {{"" ".txt"}}
   button .btn -text "Choose a file" -command {
     set f [tk_getOpenFile -filetypes $typelist]
     .l configure -text "choice: $f"
   }
   label .l -text choice:
   pack .btn .l -padx 10 -pady 10

Frames ‹↑›

Frames are very useful for grouping elements within a graphical user interface. This helps with layout problems and also allows a whole feature of the interface to be easily hidden and shown dynamically. eg with "pack forget $widget" where widget may be a frame

possible reliefs are: flat, groove, raised, ridge, solid, or sunken

label frames

In the example below the entry box gets longer (but not fatter) when the window is resized. The other elements (label and buttons) do not change their size. This behavior is dictated by the -expand and -fill attributes of the pack command.

an frame where the center text entry box resizes nicely --------- #!/usr/local/bin/wish wm title . "Frame Example" frame .f -borderwidth 10 pack .f -side top -fill x button .f.quit -text Quit -command exit button .f.go -text "Go!" -command { set tt "$tt:Click!" } pack .f.quit .f.go -side right label .f.l -text Enter: -padx 0 entry .f.text -width 20 -relief sunken -textvar tt pack .f.l -side left pack .f.text -side left -fill x -expand true bind . x exit ,,,

Labelframes ‹↑›

These are just frames with a label, of course

a simple example with a labelled frame --------- labelframe .s -text Ideas radiobutton .s.small -text Small -var size -value small radiobutton .s.med -text Medium -var size -value medium radiobutton .s.big -text Big -var size -value big s.big select pack .s.small .s.med .s.big -anchor w -padx 5 -pady 5; pack .s ,,,

reposition the label and increase its font size --------- labelframe .s -text Ideas -labelanchor wn -font {-size 16} radiobutton .s.small -text Small -var size -value small radiobutton .s.med -text Medium -var size -value medium radiobutton .s.big -text Big -var size -value big s.big select pack .s.small .s.med .s.big -anchor w -padx 5 -pady 5; pack .s ,,,

use a bitmap as the frames label --------- label .l -bitmap question labelframe .s -text Ideas -labelwidget .l radiobutton .s.small -text Small -var size -value small radiobutton .s.med -text Medium -var size -value medium radiobutton .s.big -text Big -var size -value big s.big select pack .s.small .s.med .s.big -anchor w -padx 5 -pady 5; pack .s ,,,

Notebooks Or Tabbed Frames ‹↑›

That which is called in java a 'tabbed frame', in tk is called a notebook.

create a simple notebook

    ttk::notebook .n
    ttk::frame .n.f1; # first page, which would get widgets gridded into it 
    ttk::frame .n.f2; # second page
    frame .n.f3; # second page
    .n add .n.f1 -text "One"
    .n add .n.f2 -text "Two"
    .n add .n.f3 -text "Three"
    pack .n

Labels ‹↑›

create a label with a sunken look to it

 pack [label .l -text hello -relief sunken -padx 4]

Styled or themed labels, ie ttk have a -style option which allows styles to be configured for multiple widgets at once, instead of one by one.

create a styled label (since Tk version 8.5) --------- ttk::label .label -text {Full name:} pack .label ,,,

Displaying images in 'tile' labels is the same as for the traditional tk label widget

Styling Labels ‹↑›

create 3 labels with different styles -------- label .l1 -text "This is what the default label looks like" label .l2 -text "This is a yellow label on a blue background" \ -foreground Yellow -background Blue label .l3 -text "This is a label in Times 24 font" \ -font {-family times -size 24}

# Put them in the window in row order grid .l1 -row 0 grid .l2 -row 1 grid .l3 -row 2

,,,

the dingbats -------- font create df -size 18 -family {Dingbats} set tt "A Label Font" pack [label .l -font df -textvar tt] bind . x exit ,,,

create a label that doesnt repack even when text changes ------- proc FixedWidthLabel {name values } { set maxW 0 foreach value $values { if {[string length $value] > $maxW} { set maxW [string length $value] } } label $name -width $maxW -anchor w -text [lindex $values 0] return $name } FixedWidthLabel .l {Ok Busy Error} pack .l .l config -text Ok bind . c { .l config -text Error } ,,,

Images In Labels ‹↑›

display a random gif image in a label widget

    set im [exec locate -i *.gif | shuf -n1]
    image create photo img -file $im
    pack [label .l -image img]

display a random unscaled jpeg image in a label widget

    package require Img
    set im [exec locate -i *.jpg | shuf -n1]
    image create photo img -file $im
    pack [label .l -image img]

display a 3x3 grid of random gifs ------ set ii [split [exec locate -i *.gif | shuf -n9] \n] puts [join $ii \n] option add *font {Times 16 italic} set n 0 foreach {i j k} $ii { set a [image create photo -file $i] set b [image create photo -file $j] set c [image create photo -file $k] label .labeli$n -image $a label .labelj$n -image $b label .labelk$n -image $c grid .labeli$n .labelj$n .labelk$n incr n } bind . x exit ,,,

Multiline Labels ‹↑›

create a multiline label ------- label .l -font {-size 15} -text "Multi \n Line" pack .l ,,,

another way to create a multiline label ------- label .l -font {-size 15} -text " Earth Wind Sea" pack .l ,,,

multiline white on black ------- font create fo -family Courier -size 14 set message " a - alpha b - beta c - kappa " label .l -font fo -bg black -fg white -text $message pack .l ,,,

Buttons ‹↑›

display a button with the text 'push me'

 pack [button .b -text {push me}]

create a 'tile' modern button (since Tk version 8.5)

 ttk::button .button -text "Okay" -command "submitForm"

Radio Buttons ‹↑›

group radio buttons with the -variable option

  radiobutton .left.b1 -text "Left 1"  -variable a -value one
  radiobutton .left.b2 -text "Left 2"  -variable a -value 2 
  radiobutton .left.b3 -text "Left 3"  -variable a -value three

Entry Boxes ‹↑›

create a simple entry box

set default "something" entry .foo -width 25 -textvariable default pack .foo ,,,

the -textvar name can also be held in a variable ------- set vv name pack [entry .e -width 30 -textvar $vv]; focus .e bind . <Return> { puts "name=$name" } ,,,

create a password entry box

set pass "" entry .en -width 25 -show "*" -textvariable pass pack .en; focus .en bind . <Return> { puts "pass=$pass" } ,,,

Inserting Text ‹↑›

insert text at the beginning of the entry box

    . config -borderwidth 20
    entry .e -width 20
    pack .e; focus .e
    bind . / { .e insert 0 "Insert at position 0 " }
    bind . <Return> exit

Deleting Text ‹↑›

delete all text in the entry box on / keypress

    . config -borderwidth 20
    entry .e -width 20
    pack .e; focus .e
    bind . / { .e delete 0 end }
    bind . <Return> exit

Appearance Of Entry Widgets ‹↑›

show the different border styles for an entry

    set s "styles"
    entry .en -width 40 -textvar s 
    foreach style {flat groove raised ridge solid sunken} {
      entry .e$style -width 20 -relief $style -highlightcolor blue
      .e$style insert 0 "$style border style" 
      pack .e$style -pady 5 -padx 10
    }

Selection Of Text In Entry Widgets ‹↑›

The selection is text which is highlighted blue when the mouse is dragged over it, or by some other mechanism.

select all text in the entry box on / keypress

    . config -borderwidth 20
    entry .e -width 20
    pack .e; focus .e
    bind . / { .e selection range 0 end }
    bind . <Return> exit

check if anything selected in widget

    . config -borderwidth 20
    entry .e -width 20
    pack .e; focus .e
    bind . / { 
      if { [.e selection present] } { 
        .e insert end " Yes Sel"
      } else {
        .e insert end " No Sel"
      }
    }
    bind . <Return> exit

 if {.e select present }

Hinted Entry ‹↑›

Interfaces these days often use entry boxes which display a hint to the user about what to enter into them when they are empty. The following example attempts to imitate that. This example could be developed to make the text italic, gray etc. But it seems useful as is.

an entry box which shows a message when empty --- option add *font "Courier 14" set message "" entry .e -textvariable message entry .f -width 20 bind .e <Return> { focus .f } bind .e <FocusIn> { if { $message eq "" } { #.e configure -font {-slant italic} set message "First Name:" .e selection range 0 end .e icursor end } } bind .e <FocusOut> { if { $message eq "First Name:" } { set message "" } } bind .f <Return> exit pack .e -fill x pack .f -fill x ,,,

Insertion Points For Entry Widgets ‹↑›

set the insertion cursor to the end of the text -------- set s "poems" entry .e -textvar s pack .e; focus .e .e icursor end ,,,

Entry Events ‹↑›

The entry box doesnt seem to have a <<modified>> event (unlike) the text widget. But maybe we can use the 'trace' command to achieve the same thing

doing something after an entry widget is modified -------- entry .e -width 40 -textvar t pack .e; focus .e bind .e <KeyRelease> { global t puts "Logging! $t" } ,,,

The code below works put suffers from the same problem as the <key> event. It fires before the new key is in the box...

validate an entry box using vcmd -------- entry .e -width 40 -validate key -vcmd Log -textvar tt pack .e; focus .e proc Log {} { global tt puts "Logging! $tt" return 1 } ,,,

Validation Of Text In Entry Widgets ‹↑›

tcl/tk has good mechanisms to validate text entered into the widget as the user is typing

Layouts ‹↑›

Layouts are often called 'geometry managers' in window 'grid'.

Padding ‹↑›

Padding is often the word used to describe extra bits of space which are placed around or inside widgets. This is important for aesthetic reasons

put 20 pixels of space in the toplevel window

    . configure -borderwidth 20
    pack [entry .e -width 20] [entry .f -width 20]
    bind . x exit

padx pady ipadx ipady

Dynamic Layouts ‹↑›

There seem to be 2 options here. Use grid to put windows, frames, widgets etc on top of each other, then use 'raise' etc to make the frame appear. Or else just use pack and forget with frames.

Pack ‹↑›

'pack' is a command and also a graphical layout manager. That is, it determines the geometry of the widgets which are layed out on an interface.

Pack to a side with -side top, -side left etc Fill on an axis with -fill x or -fill y use -expand to make the widget grow when the window grows. See the frame section for a good pack example.

pack 2 frames

   frame .one -width 100 -height 40  
   ...

Use 'anchor' to justify to a side of the container

left justify an entry box above a text box

   pack [entry .e] -anchor w -pady 5
   pack [text .t]

pack a series of buttons towards the left side of window

   foreach b {yellow orange green blue} {
     button .$b -text $b -bg $b -font {-size 14}
     pack .$b -side left
   }
   bind . x exit

pack some buttons from the bottom of the window

   foreach b {yellow orange green blue white} {
     button .$b -text $b -bg $b -font {-size 14}
     pack .$b -side bottom
   }
   bind . x exit

Dynamic Packing And Unpacking ‹↑›

The example below dynamically hides and shows an element (frame) of a graphical user interface. This is really usefull

a dynamic pack example with forget and pack before -------- frame .top label .top.l -text Text: entry .top.e -width 40 pack .top.l .top.e -side left pack .top -side top -fill x text .t -width 80 -height 20 pack .t -side top .t insert end [glob *] bind . h { pack forget .top } bind . H { pack .top -before .t -fill x} bind . x exit ,,,

Below is a prototype for showing help in a dynamically displayed text widget. This is suitable for a keystroke driven program. Interestingly, "pack forget" does not throw an error if the widget named is already forgotten

show help in a text box dynamically -------- wm attributes . -zoomed 1 font create df -size 14 option add *font df frame .help label .help.title -text Help text .help.t .help.t insert end " h - show help H - hide help z - make the text font bigger Z - make the text font smaller x - exit the application"

pack .help.title -fill x pack .help.t -fill both -expand 1 frame .main label .main.l -text {Main Interface: Press h for help} pack .main.l pack .main bind . h { pack forget .main pack .help -fill both -expand 1 } bind . H { pack forget .help pack .main -fill both -expand 1 } bind . z { font conf df -size [expr [font conf df -size]+2] } bind . Z { font conf df -size [expr [font conf df -size]-2] } bind . x exit ,,,

Gotchas For Pack ‹↑›

If you create a frame after a button, then the frame will obscure the button

a frame over a button, the button is hidden ------- set b [button .b -text click -command {exit}] set f [frame .f] pack .b -in .f pack .f ,,,

the correct way to do it ------- set f [frame .f] set b [button .b -text click -command {exit}] pack .b -in .f pack .f ,,,

Grid Layout Manager ‹↑›

The grid layout manager is useful for creating 'table' like layouts of widgets, where the widgets are arranged in rows and columns.

The -sticky attribute of 'grid' is equivalent to the -fill and -expand attributes of the pack geometry manager.

Each new grid command starts a new row.

layout labels and colours using grid ------ option add *font {Times 16 italic} foreach color {red orange yellow green blue purple} { label .l$color -text $color frame .f$color -background $color -width 100 -height 2 grid .l$color .f$color } ,,,

a trick to layout in 3 columns a big list

 grid .label$ii -row [expr {$ii/3}] -column [expr {$ii%3}]

layout a big list in 3 columns and lots of rows -------- set ff [lsort [font families]] set ii 0 foreach fo $ff { label .label$ii -font [list -family $fo -size 14] -text "$fo" grid .label$ii -row [expr {$ii/3}] -column [expr {$ii%3}] incr ii } bind . x exit ,,,

One use of grid is forms or data entry forms, the sort of stuff done with the html <form> tag in <table> tags (back in the day).

It is a bit surprising that the code below works without an 'eval'. When we assign -textvar $item, then a variable is created with its name being the current value of $item. How curious, but convenient.

a data entry form using grid ------ option add *font {Times 16 italic} foreach item {name age weight address} { label .l$item -text $item entry .e$item -width 30 -textvar $item grid .l$item .e$item -pady 2 -padx 3 grid .l$item -sticky w } button .b -text submit -command { puts "name=$name, age=$age, weight=$weight, address=$address" } grid .b -columnspan 2 ,,,

Sticky ‹↑›

stickiness makes the widgets align themselves in their grid cells or take up the empty space. This is a bit like -fill and -expand and -anchor for the 'pack' layout manager.

using sticky with grid layouts ------ option add *font {Times 16 italic} foreach color {red orange yellow green blue purple} { label .l$color -text $color -bg white frame .f$color -background $color -width 100 -height 2 grid .l$color .f$color grid .l$color -sticky w grid .f$color -sticky ns } ,,,

a 2 by 2 layout in a grid -------- font create ff -family Helvetica -size 30 option add *font ff button .b1 -text "Hello" button .b2 -text "Quit" button .b3 -text "B3" button .b4 -text "B4"

# Put in the grid grid .b1 -row 0 -column 0 grid .b2 -row 0 -column 1 grid .b3 -row 1 -column 0 grid .b4 -row 1 -column 1 ,,,

Exceptions And Errors ‹↑›

Use 'catch' to handle exceptional situations and errors

the simplest use of 'catch' is just to ignore errors ------ catch {exec abcd} puts "Error ignored" ,,,

catch an error and print the error message

   set f abc.txt
   if { [catch {open $f r} fid] } {
     puts stderr "An error occurred! \n$fid"
     exit 1
   }

using catch to catch errors or do something if no error

   set f abc.txt
   if { [catch {open $f r} fid] } {
     puts stderr "An error occurred! \n$fid"
     exit 1
   } else {
     puts [read fid]
   }

Events ‹↑›

view help for binding events to commands

 man 3tk bind

make the application exit when the 'e' key is pressed

 bind . <e> { exit }

 bind . e { exit }   # the same

 bind . e exit       # the same

Multiple keystrokes can also be bound to actions.

bind keystroke sequence 'qu' to an action

 bind . qu { exit }

exit when "e" pressed --- bind . <e> { exit } pack [label .l -text hello -font {-size 50} -padx 150] ,,,

exit when "x" pressed --- bind . <x> exit pack [label .l -text hello -font {-size 50} -padx 150] ,,,

stop other event handlers being used with 'break'

 bind . <e> { .l configure -text hi ; break }

The recipe below is important because it allows the coder to take advantage of the behavior which is already by default attached to some event. I think the '+' must be the first character after the bracket.

add some behaviour to the existing with '+'

 bind . <e> {+ .l configure -text hi ; break }

do something when a canvas is resized

 bind .canvas <Configure> { puts "%W is now %w %h" }

tk dialogs
tk_getOpenFile
tk_getSaveFile
tk_chooseDirectory
tk_chooseColor

a text box which displays keys pressed and symbolic names

   text .t -font {-size 14}; pack .t; focus .t
   bind .t <KeyPress> {.t insert end "You pressed the key named: %K \n"}
   bind .t <ButtonPress> {.t insert end "You pressed button: %b at %x %y \n"}

make a double click destroy a listbox widget

    listbox .lb -listvariable f
    pack .lb
    set f [list one 2 three]
    bind .lb <Double-Button-1> {+ destroy %W; break }

Destroy Event ‹↑›

check if it is the top level window being destroyed --------- pack [label .l -text test]

tk events
<ButtonRelease-2> - when the middle mouse button is released
<Button-1> - when the right mouse button is pressed

,,,

Keysyms Or Keystroke Symbols ‹↑›

The keysyms or keystroke keywords are not alway obvious, even with the help of the utilities above

interesting keysyms ---- bind .lb G { event generate .lb <Control-Home> } bind .lb gg { event generate .lb <Control-End> } ,,,

Gotchas For Keysyms ‹↑›

If keys are inexplicable not generating the correct events, look at what keyboard mapping (language) you are using. Maybe you have a spanish keyboard mapping in operation...!!!

Even more deviously, the keyboard mapping may automatically change when wish starts and then stops when is stops. A very odd error.

Mouse Events ‹↑›

use abbreviation for mouse button 1 click

 bind .lb <1> {+ focus %W}

Bindtags ‹↑›

Events can be bound to 'tags' instead of actual components. This allows a level of indirection. There are a number of tags already defined

The trick below is useful to exclude a text box from other default bindings (such as keyboard accelerators), since keystrokes are used to edit the text box

show what bindtags already exist for a widget ----- pack [text .t] .t insert end "Bindtags for text box:\n [bindtags .t]" ,,,

The code below is useful to create behaviors for when the text box does not have focus. Normally, a text box generates events which are "passed on" to the top level window ".". So if we have a binding such as

 bind . x exit

And we press "x" while typing in a Text widget, the application will exit. This is almost never what is wanted. So we can use the following trick to avoid this

 bindtags .t [list all Text .t]

remove . binding for a text box and reorder bindtags ----- pack [text .t] bindtags .t [list all Text .t] .t insert end " Press <Escape> to put focus to main window Bindtags for text box: [bindtags .t]" focus .t bind . i { .t insert end "\ni pressed with . focus \n" } bind .t <Escape> { .t insert end "\nfocus to . \n" focus . } bind . x exit ,,,

create a new bindtag and use it ----- pack [text .t] bindtags .t [list VimCmd all Text .t] .t insert end "Bindtags for text box:\n [bindtags .t]" bind VimCmd .. { %W insert end "VimCmd Bind Tag!" } #or bind VimCmd .. { .t insert end "VimCmd Bind Tag!" } ,,,

The code below is an interesting way to create a 2 mode text editor (similar to vi's insert and command modes). It comes from an example by Brent Welch, who has a great deal of time to cogitate on these matters. When the <Escape> key is pressed, the user cannot edit the text widget because all its default editing bindings are removed (by removing the the 'Text' binding tag). This is a simple way to 'disable' the text editor. But the insert cursor still blinks, which is a bit confusing for the user

Also, there are many subtleties... the 1st bindtags is used with list because there is a variable $t involved.

simple dual mode editor with bindtags ----- set t [text .t] pack $t bindtags $t [list ViInsert Text $t all] bind ViInsert <Escape> {bindtags %W {ViCmd %W all}} bind ViCmd <Key-i> {bindtags %W {ViInsert Text %W all}} ,,,

create a 'vim' style 2 mode editor using bind tags. ----- pack [text .t -font {-size 14}] bindtags .t {ViEdit all Text .t} .t insert end "Press escape for command mode" focus .t bind ViCmd <i> { bindtags %W {ViInsert Text %W all} wm title . "TkVi: Insert Mode" } bind ViCmd x exit bind ViInsert <Escape> { bindtags %W {ViCmd %W all} wm title . "TkVi: Command Mode" } ,,,

an expanded dual mode keystroke text editor ----- pack [text .t -font {-size 14}] bindtags .t [list VimEdit all Text .t] .t insert end "Press escape for command mode" focus .t

bind ViCmd <i> { bindtags %W {ViInsert Text %W all} wm title . "TkVi: Insert Mode" }

bind ViCmd x exit bind ViCmd f { # make fullscreen } bind ViCmd z { # zoom text } bind ViCmd Z { # anti zoom text } bind ViCmd c { # toggle green on black/ black on white } bind ViCmd w { # save file } bind ViCmd r { # search and replace with confirmation } bind ViCmd R { # search and replace with no confirmation } bind ViCmd / { # search and jump to } bind ViInsert <Escape> { bindtags %W {ViCmd %W all} wm title . "TkVi: Command Mode" } ,,,

remove the (.) top level window bindings from a text box

    pack [text .t] 
    bindtags .t {Text all}

make a text box uneditable by removing its default bindings

    pack [text .t] 
    bindtags .t {. all}

frames turn red on mouse enter, destroy frame on control c -------- frame .a -width 100 -height 100 frame .b -width 100 -height 100 bind Frame <Enter> {%W config -bg red} bind Frame <Leave> {%W config -bg white} bind .b <Button> {puts "Button %b at %x %y"} pack .a .b -side left bind all <Control-c> {destroy %W} bind all <Enter> {focus %W} ,,,

Generating Events ‹↑›

Generating events is so much easier than programming all the behavior of a key press in some cases

make the 'j' key act like a down-arrow ------- set ll [exec ls] listbox .lb -listvar ll -width 60 -font {-size 14} pack .lb; focus .lb bind .lb <j> { event generate .lb <Down> } ,,,

Focus Events ‹↑›

get some help for the focus command

 man 3tk focus

bind tags default
. - the top level window
Text - all text boxes
Listbox - all listboxes
all - all components	used for tabbing

set the focus to an entry widget --- option add *font "Courier 14" set var "click" entry .e -textvariable var button .b -text click pack .e .b focus .e ,,,

set text when the user clicks in a text entry box --- option add *font "Courier 14 italic" set var "click" entry .e -textvariable var entry .f bind .e <FocusIn> { set var "Focus In!!" } pack .e .f ,,,

set text when an entry box loses focus --- option add *font "Courier 14 italic" set var "click" entry .e -textvariable var entry .f bind .e <FocusOut> { set var "Focus Out!!" } pack .e .f bind . <Return> exit ,,,

Keystroke Events ‹↑›

bind commands must come after the widget they refer to, not surprisingly

The key codes shown below can be used as <Code> etc in bind commands.

an abbreviated way of specify 'e' keypress

 bind . e { exit }

show all key press codes usable with bind ----- label .l -text "Press any key to see its code" entry .e -textvar tt -font {-size 30} pack .l pack .e -padx 30 -pady 30 bind . <Key> { set tt %K } bind . <e> { exit } ,,,

bind all key strokes in an entry box and print them ------- entry .e -width 25 -font {-size 20} pack .e bind . <Key> {puts %K} ,,,

Virtual Events ‹↑›

Virtual events are denoted by double angle braces eg <<Cancel>> <<ListboxSelect>> <<Cut>> <<Copy>> <<Paste>> They provide a mechanism to smooth differences between operating systems, so that the Tcl/tk application behaves as the user expects for that particular system.

do something when a listbox selection changes ----- set ll [split [exec ls] \n] pack [listbox .lbox -listvar ll] bind .lbox <<ListboxSelect>> {ListboxChanged %W} proc ListboxChanged w { puts "Changed" } ,,,

The technique below can be used to activate the same event through different keystrokes.

create a new virtual event and use it ------- pack [label .l -text {Press 'x' or 'q' to exit}] event add <<Exit>> <Key-x> <Key-q> bind . <<Exit>> { exit } ,,,

Gotchas For Bind ‹↑›

bind <<Exit>> { do something } doesnt throw an error even though we have left out a window name

Because the % is used by the event system to indicate special values such as %W (the widget) %P (the contents of the entry box) etc etc. Then within bind commands you need to escape these with %% - if for example you are using modulus arithmetic

you have to escape % signs !!! ----- label .l -text "Percent Problem" bind . e { puts [expr {10%13}] # not what you want! puts [expr {10%%13}] # yes, is modulus arithmetic! } ,,,

Fonts ‹↑›

set the font for a label ------ label .l -font {Times 30 bold} -text Hello pack .l ,,,

times italic, very elegant. ------ label .l -font {Times 30 italic} -text Hello pack .l ,,,

see what font a widget is really using (not what you want it to use) -------- pack [label .l -font {-family Times} -text Hello] puts [.l config -font] ,,,

Italic ‹↑›

make an existing font italic

 font configure ff -family "another face" -size 24 -slant italic

Font Sizes ‹↑›

set the font in screen points ???

 -font {-size -10}

create a font which can be resized with 'z' and 'Z' ------ font create ff -size 14 -family {Courier New} label .l -text "z bigger, or Z smaller" -font ff pack .l bind . z { font conf ff -size [expr [font conf ff -size]+2] } bind . Z { font conf ff -size [expr [font conf ff -size]-2] } ,,,

create a label with big text

 pack [label .l -text hello -font {-size 50} -padx 4]

create a label with big text --- pack [label .l -text hello -font {-size 50} -padx 150] ,,,

display big text in a text box

    pack [text .t -font {-size 20}] -fill both -expand 1
    .t insert 1.0 [exec cat /usr/share/dict/words]

Configuring Fonts ‹↑›

make font bigger when a button is pressed

    button .hello -text "Hello, World!" \
      -font {-size 14 } -command {
        .hello configure -font {-size 18} 
      }
    pack .hello

Font Families ‹↑›

a listbox with all font families ---- set ff [lsort -dict [font families]]; listbox .lb -listvar ff -width 20 -font {-size 20} pack .lb ,,,

the same but with a scroll bar ---- set ff [lsort -dictionary [font fam]]; listbox .lb \ -listvar ff -width 20 -font {-size 20} \ -yscrollcommand [list .sb set] \ -selectmode single; scrollbar .sb -command [list .lb yview]; pack .lb -side left -fill both -expand true pack .sb -side right -fill y bind . x exit ,,,

The code below demonstrates the 'list' trick for supplying list values to options.

labels displayed in all available fonts -------- set ff [lsort [font families]] set ii 0 foreach fo $ff { label .label$ii -font [list -family $fo -size 14] -text "$fo" grid .label$ii -row [expr {$ii/3}] -column [expr {$ii%3}] incr ii } bind . x exit ,,,

a text box with a list of all font families -------- font create df -size 14 -family {Courier New} set ff [join [lsort [font families]] "\n"]; text .t -font df pack .t -expand true -fill both -padx 20 -pady 20 .t insert end $ff bind . x exit ,,,

the dingbats -------- font create df -size 14 -family {Dingbats} label .l -font df -text Hello pack .l puts [.l config -font] ,,,

Default Fonts ‹↑›

http://web.archive.org/web/20090302082049/http://www.tclscripting.com/articles/jun06/article1.html a good article about default fonts

create a named font to use as a default -------- font create myDefaultFont -family Helvetica -size 20 option add *font myDefaultFont ,,,

When the named font is updated, so it the widget which is using it. This allows very easy 'zooming' of text in an application.

The technique below has a problem when the font name has a space in it, in which case use the recipe above.

a default font for all widgets -------- option add *font "Times 30 italic" pack [label .l -text {Hello}] ,,,

create a named font and use it with a text box --------- font create df -size 14 -family {Courier New} pack [text .t -font df] -padx 10 -pady 10 .t insert end "Courier Font 14" ,,,

a named font with just the size --------- font create df -size 14 pack [text .t -font df] -padx 10 -pady 10 .t insert end "Some Font size 14" ,,,

'font configure' can be written 'font config' or even 'font conf'

increase/decrease label size when z/Z pressed ---- font create df -family Helvetica -size 16 label .l -text "A Named Font" -font df pack .l bind all <z> { font config df -size [expr [font config df -size]+2] } bind all <Z> { font config df -size [expr [font config df -size]-2] } bind . x exit ,,,

the same as above but much more verbose ---- font create defaultFont -family Helvetica -size 12 -slant italic label .label -text "A label with named font" -font defaultFont pack .label bind all <z> { set size [font configure defaultFont -size] incr size 2 if {$size >= 4 && $size <= 100} { font configure defaultFont -size $size } } bind all <Z> { set size [font configure defaultFont -size] incr size -2 if {$size >= 4 && $size <= 100} { font configure defaultFont -size $size } } bind all <x> { exit } ,,,

display a jpeg image in a label widget

   package require Img
   image create photo img -file "/usr/share/backgrounds/Climbing.jpg"
   pack [label .l -image img]

create a modern themed label (since Tk version8.5)

 ttk::label .label -text {Full name:}

Displaying images in 'tile' labels is the same as for the traditional tk label widget

Tree Widgets ‹↑›

The new set of widget available in tk version 8.5 have a widget for displaying 'tree' type data. If wish displays a message such as 'unknown command ttk::treeview' then you need to install wish 8.5 or activate it with 'update-alternatives' (see above)

a basic example of using the ttk::treeiew

   #package require tile
   ttk::treeview .tree
   pack .tree -side top
   .tree insert {} end -id "Item 1" -text "Item 1"
   .tree insert {} end -id "Item 2" -text "Item 2"
   .tree insert {} end -id "Item 3" -text "Item 3"

  .tree insert "Item 1" end -id "Item 1-1" -text "Item 1-1"
  .tree insert "Item 1" end -id "Item 1-2" -text "Item 1-2"
  .tree insert "Item 1" end -id "Item 1-3" -text "Item 1-3"

  .tree insert "Item 2" end -id "Item 2-1" -text "Item 2-1"
  .tree insert "Item 2" end -id "Item 2-2" -text "Item 2-2"
  .tree insert "Item 2" end -id "Item 2-3" -text "Item 2-3"

Scroll Bars ‹↑›

create a listbox with scroll bar -------- scrollbar .s -command ".l yview" listbox .l -yscroll ".s set" -font {-size 20} label .label -text "Nothing Selected" -font {-size 14}

bind .l <Double-B1-ButtonRelease> { set color [.l get active] .label configure -text $color }

grid .l -row 0 -column 0 -sticky news grid .s -row 0 -column 1 -sticky news grid .label -row 1 -column 0 -columnspan 2

.l insert 0 red green blue yellow white a b c d e \ f g h i j k l m n ,,,

Listboxes ‹↑›

get some quite abstract help for the listbox widget

 man 3tk listbox

add 'aa' at the end of a listbox .lb

 .lb insert end aa

add 3 elements to a listbox using eval

listbox .lb eval {.lb insert end} [list a b c] pack .lb ,,,

append all elements of a list to a listbox ------ listbox .lb set list [glob *] foreach item $list { .lb insert end $item } pack .lb ,,,

another way to append all elements of a list to a listbox ------ listbox .lb set list [glob *] eval {.lb insert end} $list pack .lb ,,,

create a listbox synchronized with a list variable 'l'

set l [list one 2 three] pack [listbox .lb -listvariable l] ,,,

create listbox with a list of file names in the current folder

set l [glob *] pack [listbox .lb -listvariable l] ,,,

create a listbox with elements each 1 line of stdin

set i [split [read stdin] \n] pack [listbox .lb -listvariable i] ,,,

The example below adjusts the width of the listbox to the widest element.

create a listbox with elements each 1 line of stdin --------- set ii [split [read stdin] \n] set max 1 foreach s $ii { if {[string length $s] > $max} { set max [string length $s] } } pack [listbox .lb -listvariable ii -width $max] ,,,

a listbox with sorted folder names from the 'etc' folder

set l [lsort [glob -type d -tails -directory /etc/ *]] pack [listbox .lb -height 30 -listvariable l] ,,,

a listbox with sorted folder names from the 'etc' folder

set l [lsort [glob -type d -tails -directory /etc/ *]] pack [listbox .lb -height 30 -listvariable l] ,,,

a listbox with mp3 files

set l [split [exec locate "*.mp3"] \n] pack [listbox .l -width 80 -listvariable l -font {-size 16}] ,,,

a listbox with mp3 files which deletes an item on right click

listbox .l -width 80 eval {.l insert end} [split [exec locate "*.mp3"] \n] bind .l <ButtonRelease-3> {.l delete [.l curselection]} pack .l ,,,

a listbox with mp3 files, expands when the window is resized

set l [split [exec locate "*.mp3"] \n] listbox .lb -width 80 -listvariable l grid .lb -sticky news # not working ,,,

Deleting Elements Of A Listbox ‹↑›

delete the first element of a listbox

 $listbox delete 0

delete a range of elements

 $listbox delete 3 5

delete all items in a listbox

 .lb delete 0 end

Active Element Of Listbox ‹↑›

In the example below, the selected element is not affected by the 'activate' command

activate the 2nd element when 'f' pressed --------- set ll [split [exec apt-cache search java] \n] listbox .lb -listvar ll -width 60 pack .lb; focus .lb bind .lb <f> { .lb activate 1 } ,,,

Current Selection ‹↑›

display the text of the currently selected item

 puts [.lb get [.lb curselection]]

show the currently selected item text in a label --------- set l [split [exec apt-cache search java] \n] listbox .lb -listvar l -width 60 -font {-size 14} label .l -text "?" -font {-size 14} pack .lb .l; focus .lb bind .lb <<ListboxSelect>> { .l configure -text [.lb get [.lb curselection]] } ,,,

Selection Of Listbox ‹↑›

deselect all elements between 0 and 5 when 'c' pressed --------- set l [split [exec apt-cache search java] \n] listbox .lb -listvar l -width 60 -font {-size 14} pack .lb; focus .lb bind .lb <c> { .lb selection clear 0 5 } ,,,

deselect all elements when 'c' pressed --------- set l [split [exec apt-cache search java] \n] listbox .lb -listvar l -width 60 -font {-size 14} pack .lb; focus .lb bind .lb <c> { .lb selection clear 0 [.lb size] } ,,,

select first 6 elements when c pressed --------- set l [split [exec apt-cache search java] \n] listbox .lb -listvar l -width 60 -font {-size 14} pack .lb; focus .lb bind .lb <c> { .lb selection set 0 5 } ,,,

The example below uses the LisboxSelect event which fires whenever the selection changes.

show the current selection in a label --------- set l [split [exec apt-cache search java] \n] listbox .lb -listvar l -width 60 -font {-size 14} label .l -text "?" -font {-size 14} pack .lb .l; focus .lb bind .lb <<ListboxSelect>> { .l configure -text [.lb curselection] } ,,,

The point of the example below is just to move the selection without having to remove the fingers from the keyboard. But I am sure their is an easier way... the bind commands should just substitute the arrows key for the j/k keys, since the arrow keys already have the correct bindings.

use 'vi' keys j/k to move the selection in the listbox --------- # by default list is split on white space set ll [exec ls] listbox .lb -listvar ll -width 60 -font {-size 14} pack .lb; focus .lb .lb selection set 0 bind .lb <j> { set i [.lb curselection] if {$i < [expr [.lb size] - 1]} { .lb selection clear $i incr i 1 .lb selection set $i .lb activate $i } } bind .lb <k> { set i [.lb curselection] if {$i > 0} { .lb selection clear $i incr i -1 .lb selection set $i .lb activate $i } } bind .lb <e> { exit } ,,,

a much much easier way to do the above --------- set ll [exec ls] listbox .lb -listvar ll -width 60 -font {-size 14} pack .lb; focus .lb bind .lb <j> { event generate .lb <Down> } bind .lb <k> { event generate .lb <Up> } bind .lb <x> { exit } ,,,

Searchable Listbox ‹↑›

This version is working much more quickly than using the listvariable. This is useful. It could be improved by showing and hiding the search box dynamically (pack forget $w), changing the colour of the search box when no matches. When I tried to write this code with a -listvar it was too slow. Even with a 90000 element list, this code is reasonably fast

a searchable listbox, not using a listvariable

font create df -family Helvetica -size 14 option add *font df wm attributes . -zoomed 1 set ll [split [exec apt-cache search .*] \n] #set ll [split [exec cat /usr/share/dict/words] \n] listbox .lb -width 60 entry .e -textvariable tt label .l -textvar size pack .l -side top -fill x pack .lb -fill both -expand true eval {.lb insert end} $ll set size [.lb size] focus .lb bind .lb / { pack .e -before .l -fill x; focus .e } bind .lb j { event generate .lb <Down> } bind .lb k { event generate .lb <Up> } bind .lb x exit bind .e <Return> { pack forget .e; focus .lb .lb selection set 0; .lb activate 0 } bind .e <KeyRelease> { .lb delete 0 end

focus events which can be bound to actions
FocusIn - when the widget gets focus
FocusOut - loses focus
Focus - loses or get focus

eval {.lb insert end} $ll set size [.lb size] break } foreach item $ll { if {[string match -nocase *$tt* $item]} { .lb insert end $item } } set size [.lb size] } ,,,

display all debian linux packages in a list box

set pp [split [exec apt-cache search e] \n] pack [listbox .t -height 20 -width 80 -listvariable pp] ,,,

Below is a useful email address selection panel, where the addresses are extracted from .muttrc alias lines There is a list index bug when only one email address is displayed. Also, put every thing in a frame, for easy hiding/showing. Make the search box appear and disappear

search email addresses in a listbox

font create df -family {courier new} -size 14 option add *font df wm attributes . -zoomed 1 set ll [lsort -dictionary [split \ [exec sed -n "/^alias /s/alias *//p" $env(HOME)/.muttrc] \n]] listbox .lb -width 60 entry .e -textvar tt; label .l -textvar size pack .e .l -fill x -padx 10 -pady 10 pack .lb -fill both -expand true -padx 10 eval {.lb insert end} $ll .lb selection set 0; .lb activate 0 set size [.lb size] focus .lb bind .lb / { focus .e } bind .lb <Return> { set address [.lb get [.lb curselection]] regsub -nocase {^.*?([-._a-z0-9]+@[-._a-z0-9]+).*$} $address {\1} ss puts $ss }

# make some 'vi' or 'less' like keybindings for the listbox bind .lb gg { event generate .lb <Control-Home> } bind .lb G { event generate .lb <Control-End> } bind .lb j { event generate .lb <Down> } bind .lb J { event generate .lb <Next> .lb selection clear 0 end; .lb selection set active } bind .lb k { event generate .lb <Up> } bind .lb K { event generate .lb <Prior> .lb selection clear 0 end; .lb selection set active } bind .lb x exit bind .e <Return> { focus .lb .lb selection set 0; .lb activate 0 } bind .e <KeyRelease> { .lb delete 0 end

# eval {.lb insert end} $ll # set size [.lb size] # break #} foreach item $ll { if {[string match -nocase *$tt* $item]} { .lb insert end $item } } set size [.lb size] } bind .lb z { font conf df -size [expr [font conf df -size]+2] } bind .lb Z { font conf df -size [expr [font conf df -size]-2] } ,,,

Scrolled List Box ‹↑›

Even though scroll bars are fastidious, it may be useful to use them as a visual hint to the user that there is more stuff than meets the eye.

The following example is from Brent Welch and demonstrates important tk widget procedure techniques including the use of "args" and "eval" to do useful things

a scrolled listbox, not working ....

    proc ScrollList {f args} {
      frame $f
      listbox $f.list \
        -xscrollcommand [list $f.xscroll set] \
        -yscrollcommand [list $f.yscroll set] 
      eval {$f.list configure} $args
      scrollbar $f.xscroll -orient horizontal \
        -command [list $f.list xview]
      scrollbar $f.yscroll -orient vertical \
        -command [list $f.list yview]
      grid $f.list -sticky news
      grid rowconfigure $f 0 -weight 1
      grid columnconfigure $f 0 -weight 1
      return $f.list
    }
    set l [ScrollList .f -listvar fonts]
    pack .f -expand yes -fill both
    set fonts [lsort -dictionary [font families]]
    bind . x exit

Combobox ‹↑›

The original tk did not have the 'combobox' widget (made famous by the html <select> tag), but since tk v8.5 a combobox is available in the 'ttk' namespace (which are "tile" widgets).

A ttk::combobox combines a text field with a pop-down list of values; the user may select the value of the text field from among the values in the list

display a combobox with three drop down options (tk version> 8.5)

 pack [ttk::combobox .c -textvariable state -values {nsw tas qld}]

display a combobox with file names of the current folder

ttk::combobox .c -textvariable state -values [glob *] pack .c ,,,

display a message when the combo changes, not working?

ttk::combobox .c -textvariable state -values [glob *] bind . <ComboboxSelected> { tk_messageBox -message "List box was changed" } pack .c ,,,

Text Boxes ‹↑›

A 'text box' in tcl/tk is a box which can contain editable and formattable text. It has many capabilities but in its basic form is simple to use

display the unix dictionary file in a text box

    pack [text .t -height 20 -width 80]
    .t insert 1.0 [exec cat /usr/share/dict/words]

get all text from a text widget

 $t get 1.0 end

get 1st and 3rd lines

 $t get 1.0 1.end 3.0 3.end

display the unix dictionary file in a resizable text box

    pack [text .t] -fill both -expand 1
    .t insert 1.0 [exec cat /usr/share/dict/words]

get the contents of thetext box ---- pack [text .text] -fill both -expand 1 pack [label .l -text "hello"] bind . w { set content [.text get 1.0 end]; puts $content } ,,,

pack a resizable text box

 pack [text .text] -fill both -expand 1

grid a resizable text box

grid [text .text] -sticky news grid rowconfigure 0 -weight 1 grid columnconfigure 0 -weight 1 ,,,

pack 3 widgets including a text ------- entry .to -textvar recipient -width 30 text .body label .status -text "hello" pack .to -fill y pack .body -fill both -expand true pack .status ,,,

keep the last line of a text box in view

 .t see end

another way

 .text yview moveto 1

a listbox with text files which opens the selected file on right click

listbox .l -width 70 text .t -width 80 eval {.l insert end} [split [exec locate "*.txt"] \n] bind .l <ButtonRelease-3> { set f [open [.l get [.l curselection]] r] .t delete 1.0 end .t insert 1.0 [read $f] close $f } grid .t grid .l ,,,

a dialog to choose '.txt' files and open the chosen in a text box

   set typelist {{"Text files" ".txt"} {"Latex files" ".tex"}}
   button .btn -text "Choose a file" -command {
     set f [open [tk_getOpenFile -filetypes $typelist] r]
     .t delete 1.0 end
     .t insert 1.0 [read $f]
     close $f
   }
   text .t -width 70 -height 30 
   pack .btn .t

The example below is an example of a text box with a bound scroll bar within a frame

Scrolling Or Moving Text Boxes ‹↑›

We can use the text yview command to create a simple text viewer with vi like keys

scroll down a page when L is pressed ---- pack [text .text] -fill both -expand 1 set in [open "$env(HOME)/sf/htdocs/books/tcl/tcl-book.txt"] .text insert end [read $in] pack [label .l -text "Press L to scroll down"] bind . L { .text yview scroll 1 pages } bind . x exit ,,,

viewing a text file with vi keys ---- font create df -family {Courier New} -size 14 option add *font df wm attributes . -zoomed 1 pack [text .text] -fill both -expand 1 set in [open "$env(HOME)/sf/htdocs/books/tcl/tcl-book.txt"] .text insert end [read $in] #puts "[df cget -size]" pack [label .l -text "x:exit,j:down,k:up,K:pagedown,L:pageup, g:top,G:bottom,z/Z:+/-Zoom,o:Open file"] bind . o { set f [tk_getOpenFile -filetypes {{"Text" ".txt"}}] if {$f ne ""} { .text delete 1.0 end set in [open $f] .text insert end [read $in] } } bind . j { .text yview scroll 1 units } bind . k { .text yview scroll -1 units } bind . K { .text yview scroll 1 pages } bind . L { .text yview scroll -1 pages } bind . g { .text see 1.0 } bind . G { .text see end } bind . z { font conf df -size [expr [font conf df -size]+2] } bind . Z { font conf df -size [expr [font conf df -size]-2] } bind . x exit ,,,

Scrollbars And Text Widgets ‹↑›

Some people believe that scrollbars are a useful artifact. Let them have their opinions.

create a text box with scroll bar within a frame ------- frame .t text .t.log -width 80 -height 20 -borderwidth 2 -relief raised \ -setgrid true -yscrollcommand {.t.scroll set} scrollbar .t.scroll -command {.t.log yview} pack .t.scroll -side right -fill y pack .t.log -side left -fill both -expand true pack .t -fill both -expand true .t.log insert end [exec cat /usr/share/dict/words] bind . x { exit } ,,,

Since the text widget, by default wraps lines which are too long to display, horizontal scrolling may not be that important.

a procedure to create a vertically scrolled text component

    proc ScrollText { f args } {
      frame $f
      eval {text $f.text \
        -yscrollcommand [list $f.yscroll set]} $args
      scrollbar $f.yscroll -orient vertical \
        -command [list $f.text yview]
      grid $f.text $f.yscroll -sticky news
      grid columnconfigure $f 0 -weight 1
      return $f.text
    }
    set t [ScrollText .f -width 60 -height 20 -font {courier 12}]
    pack .f -side top -fill both -expand true

    # This file join command hangs 
    # set in [open [file join /home/arjuna/sf/htdocs/books tcl "tcl-book.txt"]

    set in [open "/home/arjuna/sf/htdocs/books/tcl/tcl-book.txt"]
    $t insert end [read $in]
    close $in
    bind . x exit

Dumping Text Contents ‹↑›

dumping the contents can return all the info in a text widget including marks and tags. This is useful for transforming to another format such as Html, Pdf etc.

 $t dump ...

Searching Text ‹↑›

If ".t search" doesnt find anything, then it returns an empty string

search forward for the text 'tt'

 $t search -forward "tt"

 $t search "tt"  # the same

search backward from the 4th line for the text 'tt'

 $t search -backward "tt" 4.0

search 3rd and 4th lines only for "Q:" ignoring case

 $t search -nocase "Q:" 3.0 5.0

search for a pattern and highlight it and jump to it

  set t [text .t]; pack $t
  $t insert end "This is the Q: what to do?"
  bind . / {
    set pattern {\s+Q:}
    set start [$t search -count c -regexp -- $pattern 1.0 end]
    $t see $start
    $t tag add sel $start "$start +$c chars"
    puts $start
  }
  bind . x exit

The code below shows just how succintly Tcl/Tk can achieve complex and useful results. In 17 Lines of code a searchable text box...

a simple regexp search box which highlights the match

    option add *font "{Courier New} 14"
    set pattern {} 
    pack [entry .e -textvar pattern] -anchor w -pady 5 -padx 5
    set t [text .t]; pack $t -padx 5
    focus .e
    set in [open "$env(HOME)/sf/htdocs/books/tcl/tcl-book.txt"]
    $t insert end [read $in]
    close $in
    bind .e <Return> {
      set start [$t search -count c -regexp -- $pattern 1.0 end]
      $t see $start
      $t tag add sel $start "$start +$c chars"
      puts "Start: $start, Count: $c"
    }
    bind . x exit

The code above also gives us a template for "marking up" documents using tags. We search through the document, get a list of indice pairs (start end) and then add a tag to all those ranges, and configure the tag how ever we want.

The code below uses some tricky "index arithmetic" to loop through all matches in the document, and add the tag to those ranges. The logic could be simplified

But all this could be done much more succinctly with the -all switch to "text search". I should have read the man page

mark up all parts of a document matching a pattern

    option add *font "{Courier New} 14"
    set pattern {} 
    pack [entry .e -textvar pattern] -anchor w -pady 5 -padx 5
    set t [text .t]; pack $t -padx 5
    focus .e
    set in [open "$env(HOME)/sf/htdocs/books/tcl/tcl-book.txt"]
    $t insert end [read $in]
    close $in
    $t tag configure tt -font "Times 14 italic"
    bind .e <Return> {
      set t1 [clock milliseconds]
      if { $pattern eq "" } { break; }
      set count 0
      .t tag remove tt 1.0 end 
      set start [$t search -count c -regexp -- $pattern 1.0 end]
      while {$start ne ""} {
        incr count
        $t see $start
        $t tag add tt $start "$start +$c chars"
        #puts "Start: $start, Chars: $c: Count: $count"
        set start [$t search -count c -regexp -- $pattern "$start +$c chars" end]
      }
      set t2 [clock milliseconds]
      puts "
        Marked up $count matches of pattern $pattern
        in [expr {$t2-$t1}] ms"  
    }
    bind . x exit

We need to use index arithmetic with a mark

 $t mark set start "start +2c"

Markup Markdown And The Text Widget ‹↑›

We can use the techniques above to automatically format text which is in a particular format, so that each of the significant parts of the text is formatted distinctively.

a function to format a pattern in a document with a tag

    option add *font "{Courier New} 14"
    . config -borderwidth 20

    proc Markup { tb format pattern } {
      set count 0
      $tb tag remove $format 1.0 end 
      set start [$tb search -count c -regexp -- $pattern 1.0 end]
      while {$start ne ""} {
        incr count
        $tb tag add $format $start "$start +$c chars"
        set start [$tb search -count c -regexp -- $pattern "$start +$c chars" end]
      }
      $tb insert end "Marked Up"
    }
    
    set t [text .t -height 20]; pack $t 
    set aa [exec sed -n "/^alias /s/alias *//p" $env(HOME)/.muttrc]
    $t insert end $aa
    $t tag config mailAddress -font "Times 14 italic" -relief raised 
    Markup $t mailAddress {[^ <@]+@[^> \n]+}
    bind . x exit
    # text

Attempting to use "text search -all"

display muttrc aliases with parts formatted

    option add *font "{Courier New} 14"
    . config -borderwidth 20
    # a dodgy email address pattern
    set pattern {[^ <@]+@[^> \n]+}
    set t [text .t -height 20]; pack $t 
    set aa [exec sed -n "/^alias /s/alias *//p" $env(HOME)/.muttrc]
    #puts [join [lsort [split $aa \n]] \n]
    $t insert end "press return to mark up\n"
    $t insert end $aa
    $t tag config alias -font "Times 14 italic" -relief sunken

    bind . <Return> {
      set count 0
      .t tag remove alias 1.0 end 
      set start [$t search -count c -regexp -- $pattern 1.0 end]
      while {$start ne ""} {
        incr count
        $t tag add alias $start "$start +$c chars"
        puts "Start: $start, Chars: $c: Count: $count"
        set start [$t search -count c -regexp -- $pattern "$start +$c chars" end]
      }
      .t insert end "Marked Up"
    }
    bind . x exit

Deleting Text ‹↑›

delete the 1st and 4th lines of text

 $t delete 1.0 2.0 4.0 5.0

delete the word containing the insert cursor -------- set t [text .t] button .b -text "Delete Word" -command { $t delete "insert wordstart" "insert wordend" } pack $t .b ,,,

delete the line containing the insert cursor -------- set t [text .t] button .b -text "Delete Word" -command { $t delete "insert linestart" "insert lineend +1 char" } pack $t .b ,,,

Indices And Arithmetic ‹↑›

indice arithmetic
+2 chars
-3 chars
+4 lines
linestart
lineend
wordstart
wordend

line.char - eg 1.0 @x,y - character under screen position current - char under mouse end - after last char in document image - position of image insert - just after insert cursor mark - just after mark tag.first - first char in range tag tag.last window - position of embedded window

using indices to get current line of text

    text .t; label .l -textvar s; pack .l .t
    .t insert end "Wind Sun \n Sea Earth"
    focus .t
    bind .t <Return> {
      set s "Current Line: \
        [.t get "insert linestart" "insert lineend"]"
      break
    }
    bind . x exit

Cut And Paste In The Text Widget ‹↑›

There is an easier way to do this...

format text as it is getting pasted --------- package require Tk

proc newTextPaste w { $w delete 1.0 end set txt [::tk::GetSelection $w CLIPBOARD] regsub -all {,} $txt "\n ," txt regsub -nocase -all {\sand\s} $txt "\n and " txt $w insert 1.0 $txt }

text .t -width 80 -height 40 pack .t

bind . <<Paste>> {newTextPaste %W; break}

,,,

Text Boxes And Colours ‹↑›

-bg -background, the background colour -fg -foreground, foreground colour

display green on black text with white cursor

    font create ff -family Helvetica -size 14
    text .t -height 20 -width 80 -bg black -fg green -font ff \
      -insertbackground white 
    pack .t 
    .t insert 1.0 [exec cat /usr/share/dict/words]

Text Widget Appearance ‹↑›

a trick to find out the top level windows bg colour

 puts "[lindex [. configure -bg] 4]"

Tcl/tk labels are a bit limited. The text can only have one style or colour for example. But we can use a text widget as a replacement label.

a text widget which looks and behaves like a label ------- font create ff -family Times -size 14 text .t -font ff -borderwidth 0 -bg [lindex [. configure -bg] 4] pack .t -padx 20 -pady 20 .t tag configure rr -foreground red .t insert end "red" rr " normal" .t configure -state disabled ,,,

Tags And Styling Text ‹↑›

remove all tag info

 .t tag delete someTag

remove a tag from an entire document ------- option add *font "{Courier New} 14" set t [text .t]; pack $t -padx 5 $t insert end "A small test document to show some tag magic" $t tag configure tt -foreground white -background blue $t tag add tt 1.3 1.6 2.2 2.5

bind . d { .t tag remove tt 1.0 end } bind . x exit ,,,

insert text with a tag ------- font create ff -family Times -size 14 text .t -font ff pack .t -padx 20 -pady 20 .t tag configure rr -foreground red .t insert end "red" rr " normal" ,,,

insert text with a tag ------- pack [text .t] .t tag configure rr -foreground red -background white .t insert end "red" rr " normal" ,,,

style some text by adding tags on regions

   pack [text .t]
   .t insert  1.0  "This is an example of tagging."

   # Set some tags; they have no style as yet
   .t tag add foo 1.5 1.10
   .t tag add bar 1.15 1.20
   # Configure the tags so that we can see them
   .t tag configure foo -font {Times 16 {bold italic}}
   .t tag configure bar -foreground yellow -background blue
  ,,,,

  * use a named font with a tag 
   font create df -size 18 -family {Courier New}
   pack [text .t] -padx 10 -pady 10
   .t insert 1.0  "This is an example of tagging."

   # set a tag on a range and then configure it 
   .t tag add bigtext 1.5 1.10
   .t tag configure bigtext -font df 
  ,,,,

TAG RANGES ....

  tags can used special range numbers

  == example tag ranges
  .. 1.0 1.end - the whole of the first line
  .. 2.0 2.end - the whole of the 2nd line
  ..

  * format lines of text using tags and ranges
   font create df -size 18 -family {Courier New}
   pack [text .t] -padx 10 -pady 10
   .t insert 1.0  "First line \n Second \n Third"

   .t tag add tt 1.0 1.end
   .t tag add ss 2.0 2.end
   .t tag add rr 3.0 3.end
   .t tag configure tt -font {Times 16 {bold italic}}
   .t tag configure ss -font {{Helvetica}}
   .t tag configure rr -font {{Courier New}}
  ,,,,

  
MARKS IN TEXT ....

  * using a mark 'a' to delete text
  --------
    $t mark set a "insert worstart"  # create a mark
    $t delete a "a lineend"   # use it
    $t mark unset a   #get rid of mark 'a'


 show all marks
 mark names

 get rid of all marks in a document
 eval {$t mark unset} [$t mark names]

 show the gravity of mark 'm'
 $t mark gravity m




Selection Of Text ‹↑›

 select the current line
--------
pack [text .t]
.t insert end "
/ to select current line
w to select current word
sounds and sights
here and
there"
focus .t
bind .t / {
.t tag add sel "insert linestart" "insert lineend"
break
}
bind .t w {
.t tag add sel "insert wordstart" "insert wordend"
break
}
bind . x exit
,,,



Insertion Cursor For Text Widget ‹↑›

 move the insertion cursor to the 1st character
 .txtarea mark set insert 1.0



Undo And Redo ‹↑›

The text widget supports unlimited undo and redo of edits when
the feature has been enabled. By default these functions are bound
to <control-z> and <control-x?> respectively



Images In Text Widgets ‹↑›

We can embedd an image directly into a text widget,
instead of first embedding a label and displaying the
image in that.


 display a random gif in a text box with info
    . config -borderwidth 10
    set ii [exec locate -i *.gif | shuf -n1]
    image create photo img -file $ii 
    puts "file: $ii"
    text .t -height 20 -font {-size 14}
    .t insert end "
      gif name: $ii
      gif size: [file size $ii]
      "
    .t image create 2.10 -image img 
    pack .t -fill x
    bind . x exit




Embedded Windows In Text Widgets ‹↑›

We can put any kind of windowed widget in a text box,
including buttons, frames etc



Gotchas For Text Widgets ‹↑›

If a make a largish default font, then the text
widget goes funny and things packed after it, dont
display... This is 8.5

 font and text widget problems
-------
font create df -family {Courier New} -size 14
option add *font df
pack [text .t]
pack [label .l -text "Where am I?"]
,,,




Tkpath ‹↑›

Tkpath may be a superior version of the standard
tcl/tk canvas. It has anti aliased lines, among many
other things but requires Cairo on x11 and other
backends on other systems.



Canvases ‹↑›

The canvas is a Tk widget which allows the drawing of lines
curves shapes, and the embedding of other widgets.

 print the coordinates of mouse clicks in a canvas
    label .l -text "(x,y)"; canvas .c; pack .c .l
    bind .c <Button-1> {.l configure -text "%x,%y" }




Images On Canvases ‹↑›

By putting an image on a canvas we can do fun stuff
like drag it around, draw things on the top of it, and
so on, hours of fun.

 put an image on a canvas
    #!/usr/local/bin/wish
    package require Img
    
    canvas .can
    pack .can
    set ii "~/Pictures/mandela.png"
    set p [image create photo -file $ii]
    .can create image 0 0 -image $p -anchor nw


It is impressive that a draggable image can be
created with such little code.

 show an image that can be dragged about with the mouse
   #!/usr/local/bin/wish
   package require Img
   wm attributes . -zoomed 1

   canvas .can -bg black
   pack .can
   # select a random image from the Pictures folder
   set ii [exec locate -i */Pictures/*.jpg | shuf -n1]
   wm title . $ii
   set p [image create photo -file $ii]
   .can create image 0 0 -image $p -tag movable -anchor nw

   .can bind movable <Button-1> {
     set object [.can find closest %x %y]
     set x %x; set y %y
   }
   .can bind movable <B1-Motion> {
     .can move $object [expr %x -$x] [expr %y - $y] 
     set x %x; set y %y
   }
   bind . x exit


 make a canvas fill its container window
 pack .can -fill both -expand 1

The canvas below fills up the whole screen

 draw a fat dashed rectangle on an image with the mouse
   #!/usr/local/bin/wish
   package require Img
   
   wm attributes . -zoomed 1
   canvas .can -bg black
   pack .can -fill both -expand 1
   label .info -textvar dim
   pack .info -fill x
   set dim "x y to xx yy"
   tkwait visibility .can
   puts "Canvas dim: [winfo width .can]w x [winfo height .can]h"
   set ll [split [exec locate -i /home/*/Pictures/*.jpg] \n]
   set ii [lindex $ll [expr {[clock microseconds]%[llength $ll]}]]
   wm title . $ii
   set picture [image create photo -file $ii]
   .can create image 0 0 -image $picture 

    bind .can <Button-1> {
      set startx %x ; set starty %y
      catch {.can delete $lastbox}
      catch {unset lastbox}
    }
    bind .can <B1-Motion> {
      catch {.can delete $lastbox}
      set lastbox \
        [.can create rect $startx $starty %x %y \
          -dash {6 6} -width 4]
      set dim "box coords = ($startx,$starty) to (%x,%y)"
    }
    bind . x exit


The gotcha below is -anchor nw so that the image
doesnt get cut off (by default the anchor is center)

The code below should get the image name from standard
input, not randomly. It could be polished in many ways

 a simple but useful image crop app
   #!/usr/local/bin/wish
   package require Img
   option add *font "Times 14 italic"
   . config -bg black
   wm attributes . -zoomed 1
   canvas .can -bg black 
   pack .can -fill both -expand 1
   #pack .can 
   label .info -textvar dim
   label .status -textvar status
   pack .info -fill x
   pack .status -fill x
   set dim "x y to xx yy"
   set status "Drag mouse to select, 'c' to crop, 'v' to view crop"
   tkwait visibility .can
   set ii [exec locate -i */Pictures/*.jpg | shuf -n1]
   wm title . $ii
   image create photo orig -file $ii
   image create photo pic

   set ww [winfo width .can]; set wh [winfo height .can]
   set iw [image width orig]; set ih [image height orig]
   set factor 1 
   if { $iw>$ww || $ih>$wh } {
     if { [expr {$iw/double($ww)}] > [expr {$ih/double($wh)}] } {
       set factor [expr {int(ceil($iw/double($ww)))}]
     } else  {
       set factor [expr {int(ceil($ih/double($wh)))}]
     }
   }
   pic copy orig -subsample $factor

   puts "Canvas dim: [winfo width .can]w x [winfo height .can]h"
   puts "Image  dim: [image width orig]w x [image height orig]h"
   puts "scale factor = $factor"
   .can create image 0 0 -image pic -anchor nw 

    bind .can <Button-1> {
      set startx %x ; set starty %y
      catch {.can delete $lastbox}
      catch {unset lastbox}
    }
    bind .can <B1-Motion> {
      catch {.can delete $lastbox}
      set lastbox \
        [.can create rect $startx $starty %x %y \
          -dash {6 6} -width 4]
      set dim "box coords = ($startx,$starty) to (%x,%y)"
    }
    bind .can <ButtonRelease-1> {
      set endx %x; set endy %y
      set dim "final box coords = ($startx,$starty) to ($endx,$endy)"
    }
    bind . c {
      set x1 [expr {$startx*$factor}]
      set y1 [expr {$starty*$factor}]
      set x2 [expr {$endx*$factor}]
      set y2 [expr {$endy*$factor}]
      set newname "[file rootname $ii].crop[file ext $ii]"
      puts "
        crop ($x1,$y1) to ($x2,$y2)
        scale coord ($x1,$y1) to ($x2,$y2)
        newname = $newname"
      set t1 [clock millis]
      orig write $newname -format JPEG -from $x1 $y1 $x2 $y2 
      set t2 [clock milliseconds]
      set dim "Cropped [file tail $ii] ($startx,$starty) to ($endx,$endy) in [expr {$t2-$t1}] milliseconds !!"
      set status "new file is $newname"
    }
    bind . d { 
      file delete $newname; set status "Deleted $newname" }
    bind . v {
      image create photo pic -file $newname
    }
    bind . h {
      set status "Select with mouse, 'c' crop, 'v' view, 'd' delete "
    }
    bind . x exit





Events For Canvases ‹↑›

note 2 forms of the bind command
bind .can <...> {}
and
.can bind thing <event> {}

Dont know what the difference is



Drawing On Canvases ‹↑›



Rectangles And Squares ‹↑›

 draw a dashed square
 canvas .c; pack .c; .c create rect 10 10 80 80 -dash {6 6}

 draw a rectangle and then delete it on left mouse click
    canvas .c -bg white ; pack .c
    .c create rect 10 10 160 80 -dash {6 6} -tag abox
    bind .c <Button-1> {catch {.c delete abox}}


The recipe above shows deleting objects using tags rather than
'object ids'

 use the mouse to drag and draw lots of rectangles
    canvas .c -bg white ; pack .c
    bind .c <Button-1> {
      set startx %x ; set starty %y
      catch {unset lastbox}
    }
    bind .c <B1-Motion> {
      catch {.c delete $lastbox}
      set lastbox [.c create rect $startx $starty %x %y -tag box]
    }


 use the mouse to drag out one dashed rectangle at a time
    canvas .c -bg white ; pack .c
    bind .c <Button-1> {
      set startx %x ; set starty %y
      catch {.c delete $lastbox}
      catch {unset lastbox}
    }
    bind .c <B1-Motion> {
      catch {.c delete $lastbox}
      set lastbox [.c create rect $startx $starty %x %y -dash {6 6}]
    }




Circles And Ellipses ‹↑›

The canvas 'create oval' command creates a circle or an ellipse
The shape of the ellipse is defined by its 'bounding box'

 draw a red filled 4 pixel width border, circle on a canvas
    canvas .c ; pack .c
    .c create oval 10 10 80 80 -fill red -width 4


 draw a salmon coloured ellipse with no outline
    canvas .c ; pack .c
    .c create oval 10 10 140 80  -fill salmon1 -width 0


 draw an ellipse with a dashed outline
    canvas .c ; pack .c
    .c create oval 10 10 140 80 -dash {,}


 draw an ellipse which moves when clicked with the mouse
    canvas .c ; pack .c
    .c create oval 10 10 140 80 -fill blue -tag movable
    .c bind movable <Button-1> {
      set object [.c find closest %x %y]
      .c move $object 20 20 
    }



 draw an ellipse which can be dragged about by the mouse
    canvas .c ; pack .c
    .c create oval 10 10 140 80 -fill green -tag movable
    .c bind movable <Button-1> {
      set object [.c find closest %x %y]
      set x %x; set y %y
    }
    .c bind movable <B1-Motion> {
      set dx [expr %x - $x]
      set dy [expr %y - $y]
      .c move $object $dx $dy
      set x %x; set y %y
    }




Arcs ‹↑›

The arc, pieslice or chord is defined by a bounding rectangle

 draw a 90 degree pie slice, starting at 45 degrees
    canvas .c ; pack .c
    .c create arc 10 10 100 100 -start 45 -extent -90 -style pieslice 


 draw a 90 degree chord, starting at 45 degrees
    pack [canvas .c]
    .c create arc 10 10 100 100 -start 45 -extent -90 -style chord 



 draw a 90 degree arc, starting at 45 degrees
    pack [canvas .c]
    .c create arc 10 10 100 100 -start 45 -extent -90 -style arc




Text On Canvases ‹↑›

Text can also be placed directly into Tk canvases

 write some text which can be dragged about with the mouse
    canvas .c ; pack .c
    .c create text 50 50 -text "hello" -tag movable 
    .c create text 120 120 -text "drag me" -tag movable 
    .c bind movable <Button-1> {
      set object [.c find closest %x %y]
      set x %x; set y %y
    }
    .c bind movable <B1-Motion> {
      .c move $object [expr %x -$x] [expr %y - $y] 
      set x %x; set y %y
    }




Dynamic Interfaces ‹↑›

Standard windowed interfaces are generally terrible, caught in tired and
uncreative paradigms and dictated to by the orthodox widget libraries. It
takes ingenuity and insight to break these old bad habits. Interfaces should
be fluid and dynamic, constantly adapting to the current context and user
intentions.



Hiding Widgets ‹↑›

use 'unmap' or destroy

use pack forget .w
map



Forget And Pack ‹↑›

by packing and forgetting we can create dynamic interfaces.



Images ‹↑›

 install extended image handlers (jpeg etc) and documentation
 sudo apt-get install libtk-img libtk-img-doc

If you get an error like "couldn't recognize data in image file" then
you need to install the 'Img' extension

 display a jpeg image
   package require Img
   #image create photo img -file "/usr/share/backgrounds/Climbing.jpg"
   image create photo img -file "~/Pictures/mandela.png"
   pack [label .l -image img] ;


The following is not as fast as simply displaying
an image which is already in memory.

 one way to update an image
   #!/usr/local/bin/wish
   package require Img
   
   set pic [image create photo -file picture1.jpg]
   
   label .display -image $pic
   pack .display
   button .change -text Change -command {NewPicture}
   pack .change
   
   proc NewPicture {} {
     global pic
     $pic read ./picture2.jpg
   }
   ,,,,

RANDOM IMAGES ....

  A more succint version relying on gnu tool shuf
  * return a random image name matching a name pattern
    proc RandImage pat { 
      return [exec locate -i /home/*$pat*.jpg | shuf -n1]
    }
    puts [RandImage boat]


 return a random image name matching a name pattern
    proc RandImage pat { 
      set ll [split [exec locate -i /home/*$pat*.jpg] \n]
      set ii [lindex $ll [expr {[clock microseconds]%[llength $ll]}]]
      return $ii
    }
    puts [RandImage boat]




Images And Events ‹↑›

 scale an image by 1/2 when "z" is pressed
----
package require Img
image create photo img -file "~/Pictures/mandela.png"
image create photo temp
bind . <e> { exit }
bind . <z> {
temp copy img
img blank
img copy temp -subsample 2
temp blank
}
pack [label .l -image img] ;
,,,

The example below is freezing the computer

 scale an image by 3/4 when "z" is pressed, and 4/3 when "Z"
----
package require Img
image create photo img -file "~/Pictures/mandela.png"
image create photo temp
bind . <e> { exit }
bind . <z> {
temp copy img -zoom 3
img blank
img copy temp -subsample 4
temp blank
}
bind . <Z> {
temp copy img -zoom 4
img blank
img copy temp -subsample 3
temp blank
}
pack [label .l -image img] ;
,,,




Images ‹↑›

 install extended image handlers (jpeg etc) and documentation
 sudo apt-get install libtk-img libtk-img-doc

If you get an error like "couldn't recognize data in image file" then
you need to install the 'Img' extension



Creating Images ‹↑›

 assign image to an array variable
 set img(menu) [image create photo -arg ...]



Displaying Images ‹↑›

 display some jpeg image
    package require Img
    set f [lindex [split [exec locate -i *.jpg] \n] 0]
    image create photo img -file $f 
    pack [label .l -image img] 


 display a random jpeg image
    package require Img
    set ll [split [exec locate -i *.jpg] \n]
    set f [lindex $ll [expr { int([llength $ll] * rand()) }]]
    image create photo img -file $f 
    pack [label .l -image img] 
    bind . x exit


The recipe below seems a bit slower for various reasons, spawning a
shell, doing a 'shuf' etc

 use bash to get a random jpg image
    package require Img
    set f [exec sh -c {locate -i *.jpg | shuf | head -1}]
    image create photo img -file $f 
    pack [label .l -image img] 
    bind . x exit


 display a random jpeg image and print info about it
    package require Img
    set ll [split [exec locate -i *.jpg] \n]
    set f [lindex $ll [expr { int([llength $ll] * rand()) }]]
    image create photo img -file $f 
    pack [label .l -image img] 
    bind . i {
      puts "
        File Name: $f
        File size: [file size $f]
        Width: [image width img]
        Height: [image height img]
        "
    }
    bind . x exit


 display some png image
    package require Img
    set f [lindex [split [exec locate -i *.png] \n] 0]
    image create photo img -file $f 
    pack [label .l -image img] 


 display a jpeg 'safely' checking for existance etc
   package require Img
   set f "/usr/share/backgrounds/xfce/xfce-blue.jpg"
   label .l
   if { [file exists $f] && [file isfile $f] } {
     image create photo img -file $f
     .l configure -image img
   } else {
     .l configure -text "Couldnt find '$f'"
   }
   pack .l 
   bind . x exit


 another approach to safely opening an image using catch
   package require Img
   set f "/usr/share/backgrounds/xfce/xfce-blue.jpg"
   label .l
   if { [file exists $f] && [file isfile $f] } {
     image create photo img -file $f
     .l configure -image img
   } else {
     .l configure -text "Couldnt find '$f'"
   }
   pack .l 
   bind . x exit





Deleting Images ‹↑›

 delete all images (and free up memory)
-------
foreach name [image names] {
image delete $name
}
,,,

 delete unused images
--------
foreach name [image names] {
if {![image inuse $name]} { image delete $name }
}
,,,



Palettes Of Images ‹↑›

we can use the palette option of 'read' display an
image in greyscale or with a specified colour palette.

 display a jpeg in greyscale with 10 shades of grey
    package require Img
    set ll [split [exec locate -i *.jpg] \n]
    set f [lindex $ll [expr { int([llength $ll] * rand()) }]]
    image create photo img -palette 10 -file $f 
    pack [label .l -image img] 
    bind . x exit


 display a jpeg with 5 reds 5 greens and 4 blues
    package require Img
    set ll [split [exec locate -i *.jpg] \n]
    set f [lindex $ll [expr { int([llength $ll] * rand()) }]]
    image create photo img -palette 5/5/4 -file $f 
    pack [label .l -image img] 
    bind . x exit


 display a jpeg with 5 reds 5 greens and 4 blues
    package require Img
    set ll [split [exec locate -i *.jpg] \n]
    set f [lindex $ll [expr { int([llength $ll] * rand()) }]]
    image create photo img -palette 5/5/4 -file $f 
    pack [label .l -image img] 
    bind . x exit




Greyscale ‹↑›


 convert a jpeg to greyscale
    package require Img
    set ll [split [exec locate -i *.jpg] \n]
    set f [lindex $ll [expr { int([llength $ll] * rand()) }]]
    image create photo img -file $f 
    pack [label .l -image img] 
    img write "test.jpg" -grayscale -format JPEG
    bind . x exit


 convert a jpeg to greyscale and display info
    package require Img
    set ll [split [exec locate -i *.jpg] \n]
    set f [lindex $ll [expr { int([llength $ll] * rand()) }]]
    image create photo img -file $f 
    pack [label .l -image img] 
    img write "test.jpg" -grayscale -format JPEG
    bind . x exit


 convert a jpeg to greyscale and display info
   package require Img
   set i [expr { [clock milli]%1000}]
   set f [lindex [split [exec locate -i *.jpg] \n] $i]
   puts "Starting Conversion..."
   set t1 [clock milliseconds]
   image create photo ii -file $f 
   ii write "test.jpg" -grayscale -format JPEG
   set t2 [clock milliseconds]
   puts "
     Original file: $f
     Original size: [file size $f]
     Converted file: test.jpg 
     Converted size: [file size test.jpg]
     Conversion Time: [expr {$t2-$t1}] milliseconds
     "
    pack [label .l -image ii] 




Thumbnail Images ‹↑›

Tcllib (which has to be separately installed) contains the jpeg package
which can deal with thumbnails

 get the thumbnail from a jpeg as binary data, or empty string if none
-------
package require jpeg
set fh [open thumbnail.jpg w+]
fconfigure $fh -translation binary -encoding binary
puts -nonewline $fh [::jpeg::getThumbnail photo.jpg]
close $fh
,,,



Scaling Images ‹↑›

To scale 'down' (reduce the size of an image) we use the -subsample option of
the "copy" command.  To scale 'up' (increase image size) use -zoom

 shrink (scale down) a random image by 1/4
----
package require Img
set i [exec locate -i */Pictures/*.jpg | shuf -n1]
image create photo temp -file $i
image create photo img
img copy temp -subsample 4
image delete temp
pack [label .l -image img]
,,,

 scale up (make bigger) an image by a factor of 3
----
package require Img
set i [exec locate -i */Pictures/*.jpg | shuf -n1]
image create photo temp -file $i
image create photo img
img copy temp -zoom 3
image delete temp
pack [label .l -image img]
,,,

 scale in x and y directions
---
package require Img
set i [exec locate -i */Pictures/*.jpg | shuf -n1]
set im [image create photo]
set t [image create photo -file $i]
set xfactor 1
set yfactor 3
$im copy $t -shrink -zoom $xfactor $yfactor
image delete $t
pack [label .l -image $im]
,,,

The code below runs slowly, much more slowly than just
shrinking the image. This could be a ram problem, I suppose

 scale a random image by 3/16 and print info
----
package require Img
set f [exec locate -i */Pictures/*.jpg | shuf -n1]
set t1 [clock milliseconds]
image create photo img -file $f
image create photo temp
temp copy img -zoom 3; img blank
img copy temp -shrink -subsample 16
image delete temp
set t2 [clock milliseconds]
pack [label .l -image img]
puts "
Info
name: $f
size: [file size $f]
scale time (3/16): [expr {$t2-$t1}]
"
,,,



Scale To Window Size ‹↑›

/home/mjb/OldEEE/.local/share/Trash/files/100_1596.JPG

Firstly, it should be said, that tcl/tk cant really do
scaling to an exact pixel dimension (or it would be too
slow). But approximate scaling is fast and good.

In the code below the test "iw/ww > ih/wh" accounts for the
idea that the widget in which the image must fit is not
necessarily a square, probably a rectangle. So this test
determines whether to scale by width or height. The first
test "iw>ww || ih>wh" determines whether scaling is necessary
at all.

 perhaps the most succinct scale calculation.
--------
set ww [winfo width .w]; set wh [winfo height .w]
set iw [image width ii]; set ih [image height ii]
set factor 1
if { $iw>$ww || $ih>$wh } {
if { [expr {$iw/double($ww)}] > [expr {$ih/double($wh)}] } {
set factor [expr {ceil($iw/double($ww))}]
} else  {
set factor [expr {ceil($ih/double($wh))}]
}
}
,,,

 a function to perform the scale operation
--------
package require Img
proc ScaleToFit {w image} {
set ww [winfo width $w]; set wh [winfo height $w]
set iw [image width $image]; set ih [image height $image]
set factor 1
if { $iw>$ww || $ih>$wh } {
if { [expr {$iw/double($ww)}] > [expr {$ih/double($wh)}] } {
set factor [expr {ceil($iw/double($ww))}]
} else  {
set factor [expr {ceil($ih/double($wh))}]
}
}
return $factor
}
wm geometry . 400x300
set f [exec locate -i */Pictures/*.jpg | shuf -n1]
image create photo im -file $f
tkwait visibility .
puts "image: $f, scale factor: [ScaleToFit . im]"
,,,

We could make the above even shorter and more obscure with
an eval statement.

 an iterative way to get the scale (shrink) factor
------
set ww [winfo width .w]; set wh [winfo height .w]
set iw [image width ii]; set ih [image height ii]
set factor 1
set dividend [expr {$iw + $ih}]
if { $iw>$ih && $iw>$ww } {
while {$dividend > $ww} {
incr factor
set dividend [expr {$iw/$factor}]
}
}
if { $ih>=$iw && $ih>$wh } {
while {$dividend > $wh} {
incr factor
set dividend [expr {$ih/$factor}]
}
}
image create photo ss
ss copy ii -subsample $factor
.w configure -image ss
,,,


The technique below has the problem of scaling too much when
the operation iw/ww is an integer.

 a scaling technique iw=image width, ww=widget width
 set factor [expr {$iw/$ww + 1}]

 fixes the excessive scale problem
 set factor [expr {$iw/$ww + 1}]
puts [expr {$a<2? "a<2": "a>=2"}]

 a much more succinct technique
--------
package require Img
wm geometry . 400x300
label .w
pack .w -fill both -expand 1
tkwait visibility .w
set ll [split [exec locate -i *.jpg] \n]
set f [lindex $ll [expr {[clock microseconds]%[llength $ll]}]]
image create photo ii -file $f
set ww [winfo width .w]; set wh [winfo height .w]
set iw [image width ii]; set ih [image height ii]
set factor 1
if { $iw>$ww || $ih>$wh } {
if { [expr {$iw/double($ww)}] > [expr {$ih/double($wh)}] } {
set factor [expr {int(ceil($iw/double($ww)))}]
} else  {
set factor [expr {int(ceil($ih/double($wh)))}]
}
}
image create photo ss
ss copy ii -subsample $factor
.w configure -image ss
puts "
factor: $factor
image dimensions: $iw w X $ih h pixels
widget dimensions: $ww w X $wh h pixels
"
,,,

 a random image viewer
     package require Img
     font create df -size 15
     wm attributes . -fullscreen 1
     label .w 
     label .status -textvar status -font df
     pack .status -fill x
     pack .w -fill both -expand 1
     tkwait visibility .w
     set status "h - help"
     after 4000 { set status {} }

     image create photo ss 
     set ll [split [exec locate -i *.jpg] \n]
     set f [lindex $ll [expr {[clock microseconds]%[llength $ll]}]]
     set ww [winfo width .w]; set wh [winfo height .w]
     bind . h { 
       set status \
         "<space> - next image, h - help, x - exit, f - file name, F - favourites"
       after 4000 { set status {} }
     }
     bind . f { 
       set status $f 
       after 4000 { set status {} }
     }
     bind . F { 
       exec echo "$f" >> ~/Pictures/fav.txt
       set status "added [file tail $f] to fav.txt"
       after 4000 { set status {} }
     }
     bind . <space> {
       set f [lindex $ll [expr {[clock microseconds]%%[llength $ll]}]]
       image create photo ii -file $f
       set ww [winfo width .w]; set wh [winfo height .w]
       set iw [image width ii]; set ih [image height ii]

       set factor 1 
  
       if { $iw>$ww || $ih>$wh } {
         if { [expr {$iw/double($ww)}] > [expr {$ih/double($wh)}] } {
           set factor [expr {int(ceil($iw/double($ww)))}]
         } else  {
           set factor [expr {int(ceil($ih/double($wh)))}]
         }
       }
       puts "
         $f
         file size: [file size $f]
         widget dimensions: $ww w X $wh h pixels
         image dimensions: $iw w X $ih h pixels 
         div factor: $factor
         new dimensions: [expr {$iw/$factor}]w X [expr {$ih/$factor}]h pixels
         "
       ss blank
       ss copy ii -shrink -subsample $factor
       .w configure -image ss 
     }
     bind . x exit  



 develop the image viewer into an app:
     package require Img
     #wm geometry . 400x300
     wm attributes . -fullscreen 1
     label .w -bg black
     pack .w -fill both -expand 1
     
     entry .search -textvar find; entry .rename -textvar newname
     tkwait visibility .w
     image create photo ss 
     set ll [split [exec locate -i *.jpg] \n]
     set f [lindex $ll [expr {[clock microseconds]%[llength $ll]}]]
     set ww [winfo width .w]; set wh [winfo height .w]
     bind . / { 
       pack .search; focus .search
     }
     bind .search <Return> {
       puts $find
       pack forget .search
     }
     bind . r {
       pack .rename; focus .rename
       set newname {}
     }
     bind .rename <Return> {
       if {$newname ne ""} { 
         puts "[file dirname $f]/$newname.jpg"
         file rename $f "[file dirname $f]/$newname.jpg"
       } else { puts "Nothing renamed" }
       pack forget .rename
     }
     bind . <space> {
       set old $f 
       set f [lindex $ll [expr {[clock microseconds]%%[llength $ll]}]]
       image create photo ii -file $f
       #ii blank; ii read $f 
       set iw [image width ii]; set ih [image height ii]

       set factor 1 
       set dividend [expr {$iw + $ih}]
       if { $iw>$ih && $iw>$ww } {
         puts "w>h and scalable"
         while {$dividend > $ww} {
           incr factor; set dividend [expr {$iw/$factor}]
         }
       } 
       if { $ih>=$iw && $ih>$wh } {
         puts "h>w and scalable"
         while {$dividend > $wh} {
           incr factor; set dividend [expr {$ih/$factor}]
         }
       }

       puts "
         $f
         widget dimensions: $ww w X $wh h pixels
         image dimensions: $iw w X $ih h pixels 
         div factor: $factor
         new dimensions: [expr {$iw/$factor}]w X [expr {$ih/$factor}]h pixels
         "
       ss blank
       ss copy ii -shrink -subsample $factor
       .w configure -image ss 
     }
     bind . x exit  




Fullscreen Image Display ‹↑›

The script below is working toward displaying a set of images
from a folder in fullscreen with keystrokes cyclying through the
images. This is the beginning of a useful photo management
application

Ideas: create a favourite list (plain text), create mail lists
to particular people, based on aliases in muttrc (resize photo
to web size) resize photo, rename, add exiv comment, search by
name, search by exiv time stamp etc. Experiment with loading 2
images and swapping to see if it is faster

 full screen image display
----
package require Img
wm attributes . -fullscreen 1
. configure -bg black
#set dir /home/arjuna/Pictures/camera.9.july.2013/
set dir /home/mjb/Pictures/9.september.2013/
set ii [glob -dir $dir *.{jpg,JPG}]
set size [llength $ii]
set index 0
set thisImage [lindex $ii 0]
image create photo img -file "$thisImage"
image create photo temp

label .pic -image img -bg black
label .caption -bg black -fg white -textvar dim \
-font {-size 10}
label .status -bg black -fg green -textvar info \
-font {-size 10}

temp copy img -zoom 3
img blank
img copy temp -shrink -subsample 16
image delete temp

pack .status -side top -fill x
pack .caption -side top -fill x
pack .pic -side top -fill both -pady 20

after 200 {
set sw [winfo width .pic]
set sh [winfo height .pic]
}
set dim "[image width img]w x [image height img]h"
set info "file=$thisImage (sw=$sw sh=$sh)"

proc SetImage {} {

# find the scale (shrink factor
# where x is the image width or height and
# y is the widget width or height
# First test if image width > height
# then text if image w/h > widget w/h
# if so the scale (shrink)
set x 2345; set y 1024
for {set i 2} {$i < 1000} {incr i} {
set q [expr {$x/$i}]
if {$q < $y} {
puts "$x/$i=$q < $y";
break
}
}

global index ii dim info img size
set t1 [clock milliseconds]
set thisImage [lindex $ii $index]
image create photo temp -file "$thisImage"
set dim "[image width temp]w x [image height temp]h"
img copy temp -shrink -subsample 4
image delete temp
set t2 [clock milliseconds]
set info \
"$thisImage: loaded/scaled in [expr $t2 - $t1] ms (index:$index of $size)"
}

bind . x { exit }
bind . h {
puts " l - jump to last image "
}
bind . l {
global index
set index [expr [llength $ii] - 1]
SetImage
}
bind . j { incr index 10; SetImage }
bind . J { incr index -10; SetImage }
bind . c {
set dir [tk_chooseDirectory -initialdir "~/Pictures"]
set ii [glob -dir $dir *.{jpg,JPG}]
set index 0
set info "loaded $dir: [llength $ii] files"
set dim {}
set size [llength $ii]
SetImage
}
bind . n {
global index
incr index 1

SetImage } bind . N { global index if { $index > 0 } { incr index -1 } else { set index [expr [llength $ii] - 1] } SetImage } bind . d { exec rm "[lindex $ii $index]" img blank set info "[lindex $ii $index] was deleted permanently" set ii [glob -directory $dir *.{jpg,JPG}] set size [llength $ii] } ,,,

swapping pre loaded images -------- package require Img wm attributes . -fullscreen 1 . configure -bg black set dir /home/arjuna/Pictures/camera.9.july.2013/ set ii [glob -dir $dir *.{jpg,JPG}] image create photo img -file "[lindex $ii 0]" image create photo img2 -file "[lindex $ii 1]" image create photo temp

temp copy img -shrink -subsample 4 img blank img copy temp -shrink temp copy img2 -shrink -subsample 4 img2 blank img2 copy temp -shrink image delete temp

label .pic -image img -bg black label .caption -bg black -fg white -textvar dim \ -font {-size 10} label .status -bg black -fg green -textvar info \ -font {-size 10}

pack .status -side top -fill x pack .caption -side top -fill x pack .pic -side top -fill both -pady 20

set dim "[image width img]w x [image height img]h" set info {} bind . x { exit } bind . n { .pic configure -image img2 } bind . N { .pic configure -image img }

,,,

a listbox to choose a jpeg image to display

   package require Img
   listbox .lb -width 40 -height 40 -listvariable f
   set f [glob -directory ~/Pictures/Camera/ *.{jpg,JPG}]
   image create photo img 
   bind .lb <ButtonRelease-1> {
     img blank
     img read [.lb get [.lb curselection]]
   }
   label .l -image img
   pack .lb .l -side left

draw a gif image on a canvas centred at point (100,100)

    set i "/usr/share/doc/tk8.5/examples/images/earth.gif"
    image create photo img -file $i
    pack [canvas .c]
    .c create image 100 100 -image img

draw a gif image on a canvas anchored at 0,0

    set i "/usr/share/doc/tk8.5/examples/images/earth.gif"
    image create photo img -file $i 
    pack [canvas .c]
    .c create image 0 0 -image img -anchor nw

draw a only a 30pixel block from a gif image on a canvas

    set f "/usr/share/doc/tk8.4/examples/images/earth.gif"
    set ii [image create photo img]
    $ii read $f -from 0 0 30 30
    pack [canvas .c]
    .c create image 0 0 -image img -anchor nw

choose a gif to open from a dialog box

    set typelist {{"Gif Images" ".gif"}}
    set ii [image create photo img]
    button .btn -text "Choose an image" -command {
     set f [tk_getOpenFile -filetypes $typelist]
     $ii read $f 
    }
    canvas .c 
    .c create image 0 0 -image img -anchor nw
    pack .c .btn

copy with zoom a square block from a gif image

    set f "/usr/share/doc/tk8.4/examples/images/earth.gif"
    set ii [image create photo img -file $f]
    set jj [image create photo jj]
    $jj copy img -zoom 2 -from 30 30 100 100
    pack [canvas .c]
    .c create image 0 0 -image img -anchor nw
    .c create image 300 0 -image jj -anchor nw

draw a gif image on a canvas and display width in a label

    image create photo img -file /usr/lib/perl5/Tk/icon.gif
    label .l -text "image width: [image width img]"
    canvas .c -bg white
    pack .c .l
    .c create image 100 100 -image img

display a gif which can be dragged about with the mouse

    image create photo img -file /usr/lib/perl5/Tk/icon.gif
    canvas .c ; pack .c
    .c create image 100 100 -image img -tag movable
    .c bind movable <Button-1> {
      set object [.c find closest %x %y]
      set x %x; set y %y
    }
    .c bind movable <B1-Motion> {
      .c move $object [expr %x -$x] [expr %y - $y] 
      set x %x; set y %y
    }

display an image, select a section and write selection to file

    #package require Img
    set s "/usr/share/doc/tk8.4/examples/images/earth.gif"
    set ii [image create photo img -file $s]
    label .l -text "()"
    canvas .c -bg white ; pack .c .l
    .c create image 0 0 -image img -anchor nw
    bind .c <Button-1> {
      set startx %x ; set starty %y
      catch {.c delete $lastbox}
      catch {unset lastbox}
    }
    bind .c <B1-Motion> {
      catch {.c delete $lastbox}
      set lastbox [.c create rect $startx $starty %x %y -dash {6 6}]
      set x %x; set y %y
      .l configure -text "($startx,$starty) - ($x,$y)"
    }
    bind . <Return> {
      .l configure -text "writing selection to 'test.gif'"
      $ii write test.gif -format gif -from $startx $starty $x $y
      catch {image delete jj} 
      catch {.c delete jj}
      set jj [image create photo jj -file test.gif]
      .c create image 350 0 -image jj  -anchor nw
     }

Analysing Images ‹↑›

find out how many images are defined ------- puts [image names] ,,,,

Formats Of Images ‹↑›

show what types of image are available (!= format) ----- package require Img puts [image types] ,,,

Format Conversion ‹↑›

convert a several '.bmp' files to a different image format

   package require Img
   cd /temp
   foreach file [glob *.bmp] {
     set root [file rootname $file]
     set image [image create photo -file $file]
     foreach {format suffix} {JPEG jpg GIF gif PNG png} {
       $image write $root.$suffix -format $format
     }
   }

convert a jpeg to png format

    package require Img
    set f [exec locate -i *.jpg | shuf -n1]
    set t1 [clock millis]
    image create photo im -file $f 
    set t2 [clock millis]
    im write "$f.png" -format PNG
    set t3 [clock millis]
    puts "
      loaded $f in [expr $t2-$t1] ms, ([file size $f]bytes)
      wrote $f.png in [expr $t3-$t1] ms, ([file size $f.png]bytes)
     "

These conversions are creating massive png files, 16 times as big as the original jpeg

convert a jpeg to png format and display info

   package require Img
   set i [expr { [clock milli]%1000}]
   set f [lindex [split [exec locate -i *.jpg] \n] $i]
   puts "Starting Conversion..."
   set t1 [clock milliseconds]
   image create photo ii -file $f 
   ii write "$f.png" -format PNG
   set t2 [clock milliseconds]
   puts "
     Original file: $f
     Original size: [file size $f]
     Converted file: $f.png
     Converted size: [file size $f.png]
     Conversion Time: [expr {$t2-$t1}] milliseconds
     "

Editing Images ‹↑›

use -put {#rrggbb #rrggbb #rrggbb ... etc} or is it a list of rows

write a photo image pixel by pixel, this can be slow -------- for {set x 0} {$x<$xmax} {incr x} { for {set y 0} {$y<$ymax} {incr y} { $photo put $color -to $x $y } } ,,,

Pixels Of Images ‹↑›

We can edit images by writing pixels with the "put" command.

write a blue colour block to a photo image -------- package require Img set color blue set im [exec locate -i *.png | shuf -n1] set pic [image create photo -file $im] for {set x 0} {$x<200} {incr x} { for {set y 0} {$y<200} {incr y} { $pic put $color -to $x $y } } label .l -image $pic pack .l ,,,

another faster way to do the same -------- package require Img set im [exec locate -i *.jpg | shuf -n1] image create photo pic -file $im pic put blue -to 0 0 200 200 pack [label .l -image pic] ,,,

an array of colours -------- package require Img set im [exec locate -i *.jpg | shuf -n1] set pic [image create photo -file $im] $pic put {blue lightblue green lightgreen} -to 0 0 200 200 label .l -image $pic pack .l ,,,

write a tiny matrix of pixels to an image ------ package require Img set f [exec locate -i *pictures*.jpg | shuf -n1] set data { {red yellow green blue} {white black orange purple} {red yellow green blue} } image create photo im -file $f im put $data -to 0 0 pack [label .l -image im] ,,,

write a block of data and tile the data over the target area ------ package require Img set f [exec locate -i *pictures*.jpg | shuf -n1] set data { {red yellow green blue} {white black orange purple} {red yellow green blue} {white black orange purple} {red yellow green blue} {white black orange purple} } image create photo im -file $f im put $data -to 0 0 300 300 label .l -image im pack .l ,,,

slow way and fast ------- image create photo $pic -data $data # faster image create photo $pic $pic put $data ,,,

put a 5x5 pixel black block into an image

 $src put black -to 5 5 10 10

put a square black block into top left of photo

    package require Img
    set f [exec locate -i *.jpg | shuf -n1]
    image create photo ii -file $f 
    ii put black -to 5 5 30 30
    pack [label .l -image ii] 
    bind . x exit

put a big orange block in ------ package require Img set cc orange set f [lindex [split [exec locate -i *.jpg] \n] 50] image create photo ii -file $f ii put $cc -to 5 5 80 80 pack [label .l -image ii] bind . x exit ,,,

Note in the code below that the destination block is much bigger than the data block (which is only 3x3 pixels). So the data block just gets replicated throughout the destination block

put coloured pixel data in ------ package require Img set f [lindex [split [exec locate -i *.jpg] \n] 50] image create photo ii -file $f set data { {yellow green blue} {yellow green blue} {yellow green blue}} ii put $data -to 5 5 80 80 pack [label .l -image ii] bind . x exit ,,,

cut out a block of an image --------- set src [image create photo] set bgcolor black # load the source ... let's say it's 32x32

set dst [image create photo] $dst copy $src -from 5 5 10 10 $src put $bgcolor -to 5 5 10 10 ,,,

Drawing On Images ‹↑›

draw a green rectangle on an image ------- package require Img set f [exec locate -i *pictures*.jpg | shuf -n1] image create photo ii -file $f ii put darkgreen -to 20 20 300 40 pack [label .l -image ii] bind . x exit ,,,

draw a hollow green rectangle on an image ------- package require Img set f [exec locate -i *pictures*.jpg | shuf -n1] image create photo ii -file $f ii put darkgreen -to 20 20 300 40 ii put darkgreen -to 20 20 40 200 ii put darkgreen -to 20 200 300 200 pack [label .l -image ii] bind . x exit ,,,

Cropping Images ‹↑›

Rectangle Crop ‹↑›

The simplest image crop is a rectangle. We can just use $result copy $img -from $x1 $y1 $x2 $y2

a rectangle image crop ------- package require Img

proc RectCrop { img x1 y1 x2 y2} { set result [image create photo] set iw [image width $img] set ih [image height $img] if {$x1 > $iw} { set x1 $iw } if {$x2 > $iw} { set x2 $iw } if {$y1 > $ih} { set y1 $ih } if {$y2 > $ih} { set y2 $ih } $result copy $img -from $x1 $y1 $x2 $y2 return $result }

set f [exec locate -i *pictures*.jpg | shuf -n1] set im [image create photo -file $f] set cropped [image create photo] puts " image: $f \n size: [file size $f]" pack [label .l -image $im] wm title . "c to crop, w to save, x to exit"

bind . c { set x1 200; set y1 200; set x2 400; set y2 3000 set t1 [clock milliseconds] set cropped [RectCrop $im $x1 $y1 $x2 $y2] set t2 [clock milliseconds] puts "Cropped in [expr {$t2 - $t1}] milliseconds" .l configure -image $cropped } bind . w { set newname "[file rootname $f].circle[file ext $f]" $cropped write $newname -format JPEG puts " Saved file: $newname File size: [expr [file size $newname]/1024]K" } bind . x exit ,,,

Rounded Corner Crop ‹↑›

The code is similar to the circle crop but there are 4 for loops, one for each corner. The code is running much faster than the circle crop because we are only iterating over a small number of points

a rounded corner crop ------- package require Img

# crops an image into a rectangle with rounded # corners.

# image, topleft, bottom right, radius of corner proc RoundedCornerCrop { img x1 y1 x2 y2 radius} { set result [image create photo]

$result copy $img -from $x1 $y1 $x2 $y2 set iw [image width $result] set ih [image height $result]

# round top left corner set cx $radius; set cy $radius for {set x 0} {$x<$radius} {incr x} { for {set y 0} {$y<$radius} {incr y} { set dx [expr {$x - $cx}] set dy [expr {$y - $cy}] # test if the point is in the circle or not # if not make it white if {[expr {hypot($dx,$dy)}] >= $radius} { $result put white -to $x $y } } }

# round top right corner set cx [expr {$iw-$radius}]; set cy $radius for {set x $cx} {$x<$iw} {incr x} { for {set y 0} {$y<$radius} {incr y} { set dx [expr {$x - $cx}] set dy [expr {$y - $cy}] if {[expr {hypot($dx,$dy)}] >= $radius} { $result put white -to $x $y } } }

# round bottom left corner set cx $radius set cy [expr {$ih-$radius}]; for {set x 0} {$x<$radius} {incr x} { for {set y $cy} {$y<$ih} {incr y} { set dx [expr {$x - $cx}] set dy [expr {$y - $cy}] if {[expr {hypot($dx,$dy)}] >= $radius} { $result put white -to $x $y } } }

# round bottom right corner set cx [expr {$iw-$radius}]; set cy [expr {$ih-$radius}]; for {set x $cx} {$x<$iw} {incr x} { for {set y $cy} {$y<$ih} {incr y} { set dx [expr {$x - $cx}] set dy [expr {$y - $cy}] if {[expr {hypot($dx,$dy)}] >= $radius} { $result put white -to $x $y } } }

return $result } ; # end proc

bind . c { set x1 200; set y1 200; set x2 400; set y2 500 set t1 [clock milliseconds] set cropped [RoundedCornerCrop $im $x1 $y1 $x2 $y2 30] set t2 [clock milliseconds] puts "Cropped in [expr {$t2 - $t1}] milliseconds" .l configure -image $cropped } bind . w { set newname "[file rootname $f].circle[file ext $f]" $cropped write $newname -format JPEG puts " Saved file: $newname File size: [file size $newname]" } bind . x exit ,,,

Circle Crop ‹↑›

Rectangle crops are straight forward, but other shapes require some programming.

The code below is running very quickly 880 ms for a 100 pixel radius circle, well at least its acceptable. A rounded corner rectangle crop would be even faster

Also, this may be much faster by eliminating the function call InCircle. Nope: eliminating a function call to "InCircle" doesnt speed up the code much

I wonder if all this could be done by drawing on the canvas with geometry primitives and then saving to postscript??

another version of the image circle crop ------- package require Img

# crops an image into a circle based on a bounding # box (top left corner, bottom right corner)

proc CircleCrop { img x1 y1 x2 y2 } { set result [image create photo] # make the rectangle a square if { [expr {$x2-$x1}] > [expr {$y2-$y1}]} { set x2 [expr {$x1+$y2-$y1}] } elseif { [expr {$y2-$y1}] > [expr {$x2-$x1}]} { set y2 [expr {$y1+$x2-$x1}] }

$result copy $img -from $x1 $y1 $x2 $y2 set iw [image width $result] set ih [image height $result] set cx [expr {($x2-$x1)/2}] set cy [expr {($y2-$y1)/2}] set radius $cx

for {set x 0} {$x<$iw} {incr x} { for {set y 0} {$y<$ih} {incr y} { set dx [expr {$x - $cx}] set dy [expr {$y - $cy}] # test if the point is in the circle or not # if not make it white if {[expr {hypot($dx,$dy)}] >= $radius} { $result put white -to $x $y } } } return $result } ; # end proc CircleCrop

set f [exec locate -i *pictures*.jpg | shuf -n1] set im [image create photo -file $f] set cropped [image create photo] puts " image: $f \n size: [file size $f]" label .l -image $im label .help -textvar help pack .l .help set help "c to circle crop, w to save, x to exit"

bind . c { set x1 200; set y1 200; set x2 400; set y2 500 set t1 [clock milliseconds] set cropped [CircleCrop $im $x1 $y1 $x2 $y2] set t2 [clock milliseconds] puts "Cropped in [expr {$t2 - $t1}] milliseconds" .l configure -image $cropped } bind . w { set newname "[file rootname $f].circle[file ext $f]" $cropped write $newname -format JPEG puts " Saved file: $newname File size: [file size $newname]" } bind . x exit ,,,

Strangely this is not much slower than the version above with no function call.

a version of the image circle crop with Incircle fn ------- package require Img proc InCircle {point center radius} { #puts "$point, $center, $radius" set x [expr {[lindex $point 0] - [lindex $center 0]}] set y [expr {[lindex $point 1] - [lindex $center 1]}] if {[expr {hypot($x,$y)}] <= $radius} { return true } else { return false } } set f [exec locate -i *pictures*.jpg | shuf -n1] image create photo orig -file $f image create photo ii puts " image: $f \n size: [file size $f]" set cx 200; set cy 200; set rad 100 set t1 [clock milliseconds] set x 0; set y 0 ii copy orig -from \ [expr {max($cx - $rad, 0)}] [expr {$cy - $rad}] \ [expr {$cx + $rad}] [expr {$cy + $rad}] set iw [image width ii] set ih [image height ii] for {set x 0} {$x<$iw} {incr x} { for {set y 0} {$y<$ih} {incr y} { if {! [InCircle [list $x $y] [list $rad $rad] $rad]} { ii put white -to $x $y } } } set t2 [clock milliseconds] puts "Took [expr {$t2 - $t1}] milliseconds" pack [label .l -image ii] bind . w { set newname "[file rootname $f].circle[file ext $f]" ii write $newname -format JPEG puts " Saved file: $newname File size: [file size $newname]" } bind . x exit ,,,

crop an image in a circle with black border ------- package require Img

# crops an image into a circle based on a bounding # box (top left corner, bottom right corner, border thickness)

proc CircleBorderCrop { img x1 y1 x2 y2 border } { set result [image create photo] # make the rectangle a square if { [expr {$x2-$x1}] > [expr {$y2-$y1}]} { set x2 [expr {$x1+$y2-$y1}] } elseif { [expr {$y2-$y1}] > [expr {$x2-$x1}]} { set y2 [expr {$y1+$x2-$x1}] } $result copy $img -from $x1 $y1 $x2 $y2 set iw [image width $result] set ih [image height $result] set cx [expr {($x2-$x1)/2}] set cy [expr {($y2-$y1)/2}] set radius $cx

for {set x 0} {$x<$iw} {incr x} { for {set y 0} {$y<$ih} {incr y} { set dx [expr {$x - $cx}] set dy [expr {$y - $cy}] # test if the point is in the circle or not # if not make it white if {[expr {hypot($dx,$dy)}] > $radius} { $result put white -to $x $y } elseif {[expr {hypot($dx,$dy)}] > [expr {$radius-$border}]} { $result put black -to $x $y } } } return $result } ; # end proc

bind . c { set x1 200; set y1 200; set x2 400; set y2 500 set t1 [clock milliseconds] set cropped [CircleBorderCrop $im $x1 $y1 $x2 $y2 5] set t2 [clock milliseconds] puts "Cropped in [expr {$t2 - $t1}] milliseconds" .l configure -image $cropped } bind . w { set newname "[file rootname $f].circle[file ext $f]" $cropped write $newname -format JPEG puts " Saved file: $newname File size: [file size $newname]" } bind . x exit ,,,

Compositing Or Montage Images ‹↑›

This refers to overlaying one image on top of another. This can be done with the "copy" function

insert a shrunk image in another ------- package require Img set f [exec locate -i *pictures*.jpg | shuf -n1] set g [exec locate -i *pictures*.jpg | shuf -n1] image create photo ii -file $f image create photo jj -file $g ii copy jj -to 100 100 -subsample 4 pack [label .l -image ii] bind . x exit ,,,

insert a shrunk image in itself ------- package require Img set f [exec locate -i *pictures*.jpg | shuf -n1] image create photo ii -file $f image create photo jj -file $f ii copy jj -to 100 100 -subsample 4 pack [label .l -image ii] bind . x exit ,,,

If the source data is less that the destination area for the "copy" command, then tcl/tk automatically tiles the data onto the destination image.

tile an image on itself ------- package require Img set f [exec locate -i *pictures*.jpg | shuf -n1] image create photo ii -file $f image create photo jj -file $f set iw [expr {[image width ii] - 50}] set ih [expr {[image height ii] - 50}] ii copy jj -to 50 50 $iw $ih -subsample 6 pack [label .l -image ii] bind . x exit ,,,

Montages ‹↑›

A montage, apparently is a set of photos all stuck together side by side, the aesthetics of which are dubious to say the least The code below is incomplete, and could also be accomplished by using labels in a grid.

a diagonal tile of images of different sizes ------- package require Img set ii [split [exec locate -i *pictures*.jpg | shuf -n10] \n] set f [lindex $ii 0] image create photo ii -file $f for {set n 1} {$n<10} {incr n} { set f [lindex $ii $n] image create photo image$n -file $f ii copy image$n -to [expr {30*$n}] [expr {30*$n}] -subsample 8 } pack [label .l -image ii] bind . x exit ,,,

Metadata For Images ‹↑›

Exif Information ‹↑›

exif is textual information embedded with jpeg files.

try the tcllib::jpeg code for writing exif comments etc But you have to install tcllib first

get one value from the the exif data ------- package require jpeg set f [lindex [split [exec locate -i *.jpg] \n] 3245] array set exif [::jpeg::getExif $f] #puts "max f-stop: [::jpeg::formatExif [list MaxAperture $exif(MaxAperture)]]" puts "$exif" ,,,

get all exif info from a jpeg ------- package require jpeg set ii [lindex [split [exec locate -i *.jpg] \n] 3245] foreach {key val} [::jpeg::formatExif [::jpeg::getExif $ii]] { puts "$key: $val" } ,,,

Dimensions Of Images ‹↑›

It can be handy to interrogate image files for their dimensions. One way to do this is with exif info

get all exif info from a jpeg ------- package require jpeg set ii [split [exec locate -i *.jpg | shuf -n20] \n] foreach jpg $ii { array set exif [::jpeg::getExif $jpg] puts "max f-stop: [::jpeg::formatExif [list MaxAperture $exif(MaxAperture)]]" } ,,,

Writing Or Saving Images ‹↑›

convert a jpeg to png format

    package require Img
    image create photo myJpeg -file "image.jpeg"
    pack [label .l -image myJpeg] ;
    myJpeg write "image.png" -format PNG

Imagemagick And Tcl Tk ‹↑›

It is possible to use the imagemagick image manipulation software from within tcl/tk. This provides many additional capabilities for tcl/tk programs to transform images.

Gotchas For Images ‹↑›

When you create an image with something like .... image create photo im -file "image.jpeg" Then "im" is not a variable, it is a command name, so you dont reference it with "$im", just with "im". And you pass it to procedures in the same way eg

 [Shrink im 4]

Dashed Lines ‹↑›

Not all dash patterns are supported on all platforms (operating systems).

create a line with a 6 pixel dash and a 2 pixel space

  pack [canvas .c] ; .c create line -dash {6 2 12 6}

create a line with 6px dash, 2 px space, 12 px dash, 6, px space

  pack [canvas .c] ; .c create line -dash {6 2 12 6}

Colours ‹↑›

Ansi Escape Sequences For Colours ‹↑›

In a text only Tcl script we can use ansi sequences to print a limited number of colours. We use the standard ansi sequences but also need to escape the [ character which occurs in them (since it is special to the tclsh interpreter)

print red text on a terminal with ansi escape sequences

 puts "\033\[01;31m Red Text"

red followed by normal colour text

 puts "\033\[01;31m Red\033\[0m Normal"

print a colourful prompt and save to variable

    puts -nonewline "\033\[01;31m Enter Name: \033\[0m"
    flush stdout
    set name [gets stdin]
    puts "Hello $name"

use variables to create ansi colours --------- set greenongray "\033\[0;32;40m" set red "\033\[1;31m" puts "${red}Red Bold ${greenongray}Green On Gray" ,,,

using string map for colours

    set cc {<g> \033\[01;32m <b> \033\[01;34m <c> \033\[01;36m}
    puts [string map $cc "<b> blue <c> cyan <g> green"]

Below is a simple an useful 'colour printing' proceedure using string map etc

define a colour puts proc and use it

    proc cputs {s} {
      set cc {
        <g> \033\[01;32m <b> \033\[01;34m <c> \033\[01;36m
        <u> \033\[4;36m
        <x> \033\[24m
        }
      puts [string map $cc $s]
    }
    cputs "<b> Blue and <g> Green <u>underline<x> 
      underline off"

[1m underline [24m underline off

all colours -------- Text attributes 0 All attributes off 1 Bold on 4 Underscore (on monochrome display adapter only) 5 Blink on 7 Reverse video on 8 Concealed on

Foreground colors 30 Black 31 Red 32 Green 33 Yellow 34 Blue 35 Magenta 36 Cyan 37 White

Background colors 40 Black 41 Red 42 Green 43 Yellow 44 Blue 45 Magenta 46 Cyan 47 White ,,,

Tk Colours ‹↑›

on a unix system, show all defined tk colour names

 man 3tk colors

 showrgb    similar

show all named colors in a listbox -------- wm attributes . -fullscreen 1 set tt [exec man 3tk colors 2>/dev/null] set cc [split $tt \n] set cc [lreplace $cc 0 13] listbox .l -listvar cc -height 20 -font {-size 14} pack .l -fill x bind . x exit ,,,

not working, tricky

show all named colors in colourful labels -------- wm attributes . -fullscreen 1 set tt [exec man 3tk colors 2>/dev/null] set cc [split $tt \n] set cc [lreplace $cc 0 13] foreach item $cc { string trim $item; set colour [lindex [split $item " "] 0] puts $colour catch {eval {label .l$colour -bg $colour -text $colour}} catch {pack .l$colour} } bind . x exit ,,,

Rgb Colours ‹↑›

Rgb as you may guess means red green blue

example rgb values

 #FF8080 #F80

Random Colours ‹↑›

This is a nice test pattern

create random colours ------- proc randomColor {} {format #%06x [expr {int(rand() * 0xFFFFFF)}]} set ii 0 while {$ii < 40} { foreach n {a b c d e} { frame .$n$ii -width 100 -height 20 -bg [randomColor] } grid .a$ii .b$ii .c$ii .d$ii .e$ii incr ii } bind . x exit ,,,,

Named Colours ‹↑›

convert a colour name in rgb values (a list)

 winfo rgb . red

convert a colour name into a valid rgb format

 eval format "#%04x%04x%04x" [winfo rgb . red]

Modifying Colours ‹↑›

This does something but not sure what.

darken a colour slightly ------ set color orange frame .f -width 100 -height 20 -bg $color pack .f set new [::tk::Darken $color 1000] frame .g -width 100 -height 20 -bg $new pack .g ,,,

Exec And Pipes ‹↑›

an exec example

 set n [exec sort < /etc/passwd | uniq | wc -l 2> /dev/null]

pipe both stdout and stderr to stdout

 exec find . -name '*aa*' |& cat

display the unix dict file in a text box

pack [text .t -height 20 -width 80] .t insert 1.0 [exec cat /usr/share/dict/words] ,,,

display all debian linux packages in a list box

set pp [split [exec apt-cache search e] \n] pack [listbox .t -height 20 -width 80 -listvariable pp] ,,,

display files from a directory in a text box using a pipe

set f [open "|ls" r] set s [read $f] close $f pack [text .t -height 20 -width 80] .t insert 1.0 $s ,,,

display the 1st 10 text files in a listbox

pack [listbox .t -height 20 -width 80 -listvariable results] catch {exec locate "*.txt" | head -10 } results ,,,

The recipe above illustrates a tcl 'exec' problem, "write on pipe with no readers". This occurs when a process that takes a long time (in this case 'locate') writes to a process that exits quickly ('head').

spawn a shell to get rid of this problem

 set entropyfeed [exec sh -c {tr -dc '[:graph:]' < /dev/urandom | head -c 320}]

a minimalist email sender via exec and mutt ------ set recipient "mjbishop@fastmail.fm" set about "stuff" label .l -text Email text .t entry .to -textvar recipient entry .sub -textvar about pack .l .to .sub .t -fill x -padx 2 -pady 2; focus .t bind .l x exit bind .l s { set message [.t get 1.0 {end -1c}] puts " Sending mail to <$recipient> Subject:$about Message:\n$message" exec echo "$message" | mutt -s "$about" $recipient } bind . xxx { focus .l } ,,,

Errors With Exec ‹↑›

When a command executed with 'exec' writes to stderr or returns a non zero result, exec throws an error. Which is inconvenient, but can be overcome by calling exec within a catch clause.

redirect stderr from an exec call

 puts [exec man 3tk colors | cat 2>/dev/null]

another way to redirect stdout and stderr

 exec man 3tk colors &| less

Gotchas With Exec ‹↑›

With long pipes with exec you get a problem with the message "child killed: write on pipe with no readers"

 set f [exec locate -i *.jpg | shuf | head -1 ]

spawn a shell to get rid of probs

 set entropyfeed [exec sh -c {tr -dc '[:graph:]' < /dev/urandom | head -c 320}]

Killing Processes ‹↑›

open a process and then kill it later

    set pipe [open "|mplayer a.wav"]
    set p [pid $pipe]
    exec kill $p

Printing ‹↑›

Pdf ‹↑›

But where can we find this package?

an example of using the pdf4tcl package -------- package require pdf4tcl pdf4tcl::new mypdf -paper a3 mypdf startPage mypdf setFont 12 Courier mypdf text "Hejsan" -x 50 -y 50 mypdf write -file mypdf.pdf mypdf destroy ,,,

Sound And Audio ‹↑›

play a random wav file ------- set ii [exec locate -i *.wav | shuf -n1] puts "file is $ii" exec play $ii ,,,

a listbox which plays an mp3 when enter is pressed

set ll [split [exec locate "*.mp3"] \n] pack [listbox .l -width 80 -listvariable ll -font {-size 16}] bind all <Return> { exec mplayer [.l get active] & } bind all x exit ,,,

play audio files with spaces in the name

 set pipe [open "|mplayer \"[.l get active]\""]

play and stop playing wavs and mp3s

wm attributes . -zoomed 1 set ll [split [exec locate "*.mp3" "*.wav"] \n] wm title . "Found [llength $ll] audio files" pack [listbox .l -listvariable ll -font {-size 16}] -fill both -expand 1 focus .l bind all <Return> { set pipe [open "|mplayer \"[.l get active]\""] set p [pid $pipe] } bind all s { exec kill $p } bind all j { event generate .l <Down> } bind all x exit ,,,

a simple app to play and delete audio

# would be good to make it searchable

wm attributes . -zoomed 1 . config -borderwidth 20 font create ff -size 14; option add *font ff set ll [split [exec locate "*.mp3" "*.wav"] \n] set help \ "Enter - play, s - stop, i - info, d - delete (careful!), + vi keys" wm title . "Found [llength $ll] audio files: $help" pack [listbox .l -listvariable ll -font ff] -fill both -expand 1 focus .l bind all <Return> { set pipe [open "|mplayer \"[.l get active]\""] set p [pid $pipe] wm title . "Playing audio [.l get active]" } bind all s { exec kill $p wm title . "Stopped playing [.l get active] audio" } bind all i { set f [.l get active] wm title . "File: [file tail $f], size [file size $f]" } bind all d { set f [.l get active] set index [.l curselection] set l [lreplace $ll $index $index] file delete $f wm title . "Deleted $f audio [file size $f]b, hope thats OK!" } bind all j { event generate .l <Down> } bind all J { event generate .l <Next> } bind all k { event generate .l <Up> } bind all K { event generate .l <Prior> } bind all G { event generate .l <Control-Home> } bind all gg { event generate .l <Control-End> } bind all h { wm title . "[llength $ll] audio files: $help " } bind . z { font conf ff -size [expr [font conf ff -size]+2] } bind . Z { font conf ff -size [expr [font conf ff -size]-2] } bind all x exit ,,,

Snack ‹↑›

Snack is a good library, designed to be used with scripting languages such as tcl/tk

install the snack library for tcl tk on a debian system

 sudo apt-get install libsnack2-alsa

 sudo apt-get install libsnack2  older...

May have to uninstall libsnack2 before installing libsnack2-alsa. libsnack2 is something called oss which is older apparently

use the snack sound library with tcl/tk

 package require snack

May have to change /dev/dsp if using alsa module maybe hw,0:0 ???. The code is running with alsa without errors but no sound is heard

play a wav sound file, using snack

    package require snack
    #snack::audio selectOutput /dev/dsp 
    snack::sound s
    set f [exec locate -i *.mp3 | shuf -n1]
    puts "playing $f"
    #s read /home/matth3wbishop/yolngu/audio/one/0234s.mp3
    # s read snack2.2a1/demos/tcl/ex1.wav 
    s read $f 
    s play

the same

    package require snack
    snack::sound s -load /home/mjb/sf/htdocs/audio/ja/tsuma.wav
    s play

snack can convert formats, can play mp3s etc

Wav form drawing is working

draw the waveform of a sound

    package require snack
    snack::sound snd 
    snd read /home/mjb/sf/htdocs/audio/ja/tsuma.wav
    #snd play
    canvas .c; pack .c 
    .c create waveform 0 0 -sound snd

Exec Gotchas ‹↑›

If the external program writes to 'standard error' (stderr) then you need to use catch

 catch {exec wget ...} results

dont enclose the whole exec in " quotes (like a c 'system' call or a perl 'exec')

 exec "blah ..."  ## error

Dont use single quotes (') they dont work

Environment And Platform ‹↑›

see help for environment variables

 man 3tcl tclvars

show the architecture of machine

 puts $tcl_platform(machine)

show some computer specific information --------- puts " Architecture of machine: $tcl_platform(machine) Operating System: $tcl_platform(os) Os version: $tcl_platform(osVersion) Is Tcl/tk threaded: $tcl_platform(threaded) User: $tcl_platform(user) " ,,,

Cross Platform Issues ‹↑›

Android ‹↑›

The androwish app for android appears very promising, actively developed (oct 2015) and even with some advantages over traditional platforms (aliased drawing for example)

Deployment ‹↑›

Use tclkit to make a stand alone tcl/tk app Investigate starkits and starpacks

The 'freewrap' tool claims to be able to wrap tcl/tk apps as stand alone executables for windows and linux. This seems to good to be true, since the target machine doesnt have to have wish or tclsh installed in order to run the app. active dev but no deb package

http://freewrap.sourceforge.net/

Email And Tcl Tk ‹↑›

look at exmh a tcl/tk interface for the unix mh mail system. written by brent welch

Bash And Tcl Tk ‹↑›

Since tcl and tk are interpreters they can be used directly from bash by piping input to 'wish' and 'tclsh'

echo hello to standard output

 echo "puts hello" | tclsh

get an iso formatted date from a date string

 echo "puts [clock format [clock scan {tomorrow}]]" | wish

converting a bash date string to eg: Friday, 14 August 2014

 a=today; echo 'puts [clock format [clock scan "'$a'"] -format {%A, %d %B %Y}]' | tclsh

test if a string is today in bash ------

dash patterns
. - dash 1/2 length of following space
	- dash equal in length to following space
- - dash 1 1/2 times longer than space
_ - twice as long as following space
<space> - longer space

,,,

execute a tcl statement using echo & eval from the bash shell

 eval echo 'wm title . "hi"' | wish

The technique below is useful for including short tcl/tk scripts within a bash script file

use a 'here document' to execute some tk commands

    wish << xx
    wm title . "hello"
    button .b -text push -command {exit}
    pack .b
xx

another way to run a here document

   cat << eos | tclsh
     puts "Seconds: [clock seconds]"
eos

a vim command to execute in bash

 command! Bmr ?^ *---?+1,/^ *,,,/-1w !sed 's/^ *>>//' | bash | less

Vim And Tcl Tk ‹↑›

Since vim is the editor I am used to I find it easier to use than editing in a tcl/tk text widget

Using Vim From With Tcl Tk ‹↑›

The code below is not working because vim needs a terminal to run, so how can we use vim from within tcl/tk???

launch vim ----- set typelist {{"Text File" {".txt"}} } button .btn -text "Choose a text file" -command { set f [tk_getOpenFile -filetypes $typelist] exec bash -c vim $f } pack .btn -padx 20 -pady 20 ,,,

Vim Commands ‹↑›

execute the current file as a tcl or tk script (from within 'vim')

 :!./%

start vim in a particular folder

 vim -c "cd C:/pro"

start vim and change to folder of file being edited

 vim -c 'cd %:p:h' ~/docs/info.txt

execute the current line as a tcl/tk script

 :.w !wish

Below is a one line tcl/tk script piped to wish and set up as a map in the .vimrc file.

a mapping to show 'keysyms' or key code, for events

 map ,k :!echo "bind . <Key> {puts \%K}" \| wish <cr>

another version, easier to exit

 map ,k :!echo "bind . <Key> {puts \%K};bind . e {exit}" \| wish <cr>

make a mapping to execute current line as a tk script

 map ,dd :.w !sed 's/^ *>>//' \| wish

remove the 2 '>' characters and execute current line as a tk command

 :.w !sed 's/^ *>>//' | wish

write out a fragment to a file, overwriting if file exists

 comm! App ?^ *---?+1,/^ *,,,/-1w! app/new.tcl

a command to execute fragment between '---' and ',,,' with bash

 command! Bmr ?^ *---?+1,/^ *,,,/-1w !bash | less

make a mapping to execute current line as a tcl script

 map ,tc :.w !sed 's/^ *>>//' \| tclsh

make a mapping to execute current line as a tk script

 map ,tk :.w !sed 's/^ *>>//' \| wish

execute between --- and ,,, as tk commands

 command! Tk ?^ *---?+1,/^ *,,,/-1w !wish

execute the fragment between --- and ,,, as a tcl script

 command! Tc ?^ *---?+1,/^ *,,,/-1w !tclsh

execute the current line as a tcl command

 command! Tcl .w !sed 's/^ *>>//' | tclsh

create vim maps to show help for tcl/tk keywork, widget etc

 nmap ,htk :!man 3tk <cword> <cr>

 nmap ,htc :!man 3tcl <cword> <cr>

a map to indent tcl code fragments

 map ,ti :?^ *---?+1,/^ *,,,/-1! astyle -s2 <bar> sed 's/^/   /'<cr>

Vimrc Example Code ‹↑›

a set of useful vim maps and commands to go in vimrc


   " a mapping to show tk keysyms or codes
   map ,k :!echo "bind . <Key> {puts \%K}" \| wish <cr>

   " execute the current file as Tk or Tcl
   command! Tkx 1,$w ! wish
   command! Tcx 1,$w ! tclsh

   "show the tk/tcl man page for the word under cursor
   "help must be installed
   nmap ,htk :!man 3tk <cword> <cr>
   nmap ,htc :!man 3tcl <cword> <cr>
   command! Htk !man 3tk <cword> <cr>
   command! Htc !man 3tcl <cword> <cr>

   " a command to sometimes show valid options
   command! Hto !echo "catch {<cword> -xx} r; puts [lindex [split \$r :] 1]" | wish

   " a vim command to display all tcl/tk commands
   command! Hcc !echo "puts [lsort [info commands]]; bind . x exit" | wish
   
   "a mapping to execute current line as a tk script
   map ,tc :.w !sed 's/^ *>>//' \| tclsh
   map ,tk :.w !sed 's/^ *>>//' \| wish

   " commands to execute tcl/tk fragments
   command! Tc ?^ *---?+1,/^ *,,,/-1w ! tclsh
   command! Tcl .w !sed 's/^ *>>//' | tclsh
   command! Tk ?^ *---?+1,/^ *,,,/-1w ! wish                 
   command! Tkl .w !sed 's/^ *>>//' | wish

   " write a temporary file and then run
   command! Tc ?^ *---?+1,/^ *,,,/-1w test.tcl !tclsh test.tcl
   
   " export a fragment (recipe) as an app 
   comm! -nargs=1 App ?^ *---?+1,/^ *,,,/-1w app/<args>
   comm! -nargs=1 AppOver ?^ *---?+1,/^ *,,,/-1w! app/<args>

   " append a fragment to the app script file
   comm! -nargs=1 AppA ?^ *---?+1,/^ *,,,/-1w >>app/<args>

Performance ‹↑›

Speed ‹↑›

see time and date for a simple way to use [clock milliseconds] to get some speed performance info

Memory Usage ‹↑›

to see how much memory some tcl/tk code uses you could try comparing the vsize (as reported by ps) of tclsh before and after evaluating the code

an example --------- package require Img puts [exec ps p [exec pidof wish] -o vsize] set ll [split [exec locate -i *.jpg] \n] set f [lindex $ll [expr { int([llength $ll] * rand()) }]] puts "File size: [file size $f]" image create photo img -file $f label .l -image img pack .l puts [exec ps p [exec pidof wish] -o vsize] bind . x exit ,,,

Debugging ‹↑›

Wish can give you better error messages than tclsh even when your app is only tcl!!! So if you have an intractable buggy program try running it in wish.

Notes ‹↑›

use 'cget' to get current option values: this may simplify some existing code.

tk_setPalette changes the colour scheme for the whole app

use lset to set 2 variables at once from a split etc

 lset {a, b} [split "one:two" :]

Use Tkhtml 3.0 to display labels with formatted text amongst other uses.

Use tclsh on ms windows to display tk interfaces, because tclsh outputs puts to the console (command line) where as wish returns immediately. This can be handy for debugging purposes.

DOCUMENT-NOTES:

Tcl and Tk

Table of Contents

Command Line Options ‹↑›

Executing Tk ‹↑›

Gotchas Executing Tcl Tk ‹↑›

Help ‹↑›

Proceedures Or Functions ‹↑›

Default Arguments Or Parameter Values ‹↑›

Global Variables And Procedures ‹↑›

Function Pointers ‹↑›

Maps ‹↑›

Recursive Proceedures ‹↑›

Widget Procedures ‹↑›

Libraries And Packages ‹↑›

Running Scripts ‹↑›

Useful Libraries ‹↑›

Ternary Operator ‹↑›

Control Flow ‹↑›

If Then Etc ‹↑›

Loops ‹↑›

For Counted Loop ‹↑›

While Loops ‹↑›

Foreach Loops ‹↑›

Input ‹↑›

Arithmetic And Mathematics In Tcl ‹↑›

Subtraction ‹↑›

Double Or Decimal Numbers ‹↑›

Integer Techniques ‹↑›

Math Functions ‹↑›

Expr ‹↑›

Gotchas For Expr ‹↑›

Random Numbers ‹↑›

Powers Of Numbers ‹↑›

Modulus Arithmetic ‹↑›

Pythagoras Theorem ‹↑›

Trigonometry ‹↑›

Comparisons ‹↑›

Geometry ‹↑›

Variables ‹↑›

Global Variables ‹↑›

Unicode ‹↑›

Kanji ‹↑›

Fonts For Unicode Characters ‹↑›

Comments ‹↑›

Strings ‹↑›

Comparing Strings ‹↑›

Matching Strings ‹↑›

Concatenating Or Joining Strings ‹↑›

Formatted String Output ‹↑›

Scan ‹↑›

Substrings ‹↑›

Splitting Strings ‹↑›

Substituting In Strings ‹↑›

Length Of Strings ‹↑›

Interpolating In Strings ‹↑›

Whitespace ‹↑›

Regular Expressions ‹↑›

Submatches ‹↑›

Non Greedy Matching ‹↑›

Lists And Regular Expressions ‹↑›

Unicode Regexp Patterns ‹↑›

Gotchas For Regular Expressions ‹↑›

Uppercase And Lowercase ‹↑›

Paragraph Matching ‹↑›

Lists ‹↑›

Accessing Elements Of A List ‹↑›

Random Elements Of A List ‹↑›

Lassign ‹↑›

Deleting Elements ‹↑›

Joining Lists ‹↑›

Constructing Lists ‹↑›

Filtering Lists ‹↑›

Mapping Lists ‹↑›

Sorting Lists ‹↑›

Iterating Lists ‹↑›

Arrays ‹↑›

Creating Arrays ‹↑›

Accessing Elements ‹↑›

Analysing Arrays ‹↑›

Iterating Arrays ‹↑›