TCL







TCL is a script language, like PERL. TCL is avalaible for UNIX, Windows, even Machintosh.





Basics



puts "words";
puts (words};

set string "toto";
puts $string;
puts "this is $string"

words
(words}
toto
this is toto


Math expressions



set a "1";
set b "2";
puts "a=$a and b=$b";
set X [expr $a + $b];
puts "$X";
set X [expr 5+2];
puts "$X";

a=1 and b=2
3
7


Tests



set x "toto";
switch $x \
  "ONE" "puts ONE=1" \
  "TWO" "puts TWO=2" \
  "default" "puts NO_MATCH";

NO_MATCH

set x "toto";
switch $x \
  "ONE" "puts ONE=1" \
  "TWO" "puts TWO=2" \
  "toto" "puts MATCH" \
  "default" "puts NO_MATCH";

MATCH

set x "1";
if {$x == 1} \
then \
{ \
  puts "x=1"; \
  } else { \
  puts "x!=1"; \
}

x=1


Loop



set x "0";
while {$x < 10} \
{ \
  puts "x = $x"; \
  set x [expr $x+1]; \
}

x = 0
x = 1
x = 2
x = 3
x = 4
x = 5
x = 6
x = 7
x = 8
x = 9

for { set i "0"; } {$i < 10} {set i [expr $i+1];} \
    { puts "$i"; };

for { set i "0"; } {$i < 10} { incr i; } \
    { puts "$i"; };

0
1
2
3
4
5
6
7
8
9
0
1
2
3
4
5
6
7
8
9


Procedure



proc toto {a b} \
{ \
  set x [expr $a+$b]; \
  return $x; \
};

set y [toto "33" "20"];
puts "$y";

53

proc toto { first args } \
{ \
  puts "args = $args"; \
  puts "first = $first"; \
};

puts "[toto a b c d]";
args means "variable number of arguments".
args = b c d
first = a

proc toto { {first "11"} } \
{ \
  puts "first = $first"; \
};

puts "[toto]";
puts "[toto 10]";
The {...} means "default value".
first = 11

first = 10

proc toto { x y } \
{ \
  upvar $x pointer1 $y pointer2; \
  set pointer1 "10"; \
  set pointer2 "20"; \
};

proc print {} \
{ \
  set y "22"; \
  set z "12"; \
  puts "y=$y z=$z"; \
  toto y z; \
  puts "y=$y z=$z"; \
}

print;
upvar $x var means that 'x' can be see as a C pointer.
y=22 z=12
y=10 z=20


List



set tab {a b c d};
set x [lindex $tab 2];
puts "$x";
lindex $tab 2 means "return the element that index is 2".
c

set tab [split "el1.el2.el3" "."];
set x [lindex $tab 2];
puts "$x";
puts "[lindex $tab 1]";
split takes the string "el1.el2.el3" and extracts each elements separated by a ".". So the string "el1.el2.el3" returns the list {el1 el2 el3}.
el3
el2

set tab [list "el1_" "el2_" "el3_"];
set x [lindex $tab 2];
puts "$x";
puts "[lindex $tab 1]";
list just creates a list.
el3_
el2_

set tab [list "el1_" "el2_" "el3_"];
set n "0";
foreach i $tab \
{ \
  puts "$n: $i"; \
  incr n; \
};
foreach takes each item of a list, one at the time.
0: el1_
1: el2_
2: el3_

set list1 [list a b c d];
set list2 [list "e1" "e2" "e3" "e4"];
set list3 [concat $list1 $list2];
puts "list3 = $list3";

list3 = a b c d e1 e2 e3 e4

set list3 [list a b c d "e1" "e2" "e3" "e4"];
lappend list3 {1 2} "toto"
puts "list3 = $list3";

list3 = a b c d e1 e2 e3 e4 {1 2} toto

set list3 [list a b c d "e1" "e2" "e3" "e4" {1 2} "toto"];
set list4 [lreplace $list3 8 9 "el8" "el9"];
puts "list4 = $list4";

list4 = a b c d e1 e2 e3 e4 el8 el9

set list3 [list a b c d "e1" "e2" "e3" "e4" {1 2} "toto"];
set list5 [linsert $list3 4 "elem1 elem2"];
puts "list5 = $list5";

list5 = a b c d {elem1 elem2} e1 e2 e3 e4 {1 2} toto

set list1 [list {toto est la} "e2" "e3" "e4"];

set zz [lsearch $list1 toto*];
puts "index of \"toto*\" = $zz";
puts "list1\[$zz\] = [lindex $list1 $zz]";

index of "toto*" = 0
list1[0] = toto est la

set list1 [list {toto est la} "e2" "e3" "e4"];
set sorted [lsort $list1];
puts "$sorted";

e2 e3 e4 {toto est la}

set list1 [list {toto est la} "e2" "e3" "e4"];
set cutted [lrange $list1 1 3];
puts "$cutted";

e2 e3 e4


Strings



set chaine "my string";
puts "the size of \"$chaine\" is [string length $chaine]";
puts "the character index 3 of \"$chaine\" is [string index $chaine 3]";
puts "chaine\[3..7\]: [string range $chaine 3 7]";

the size of "my string" is 9
the character index 3 of "my string" is s
chaine[3..7]: strin

set s1 "toto1";
set s2 "toto2";
set s3 "toto2";

if { [string compare $s1 $s2] == 0} \
then \
{ \
   puts "\"$s1\" equal \"$s2\""; \
} \
else \
{ \
   puts "\"$s1\" not equal \"$s2\""; \
};

if { [string compare $s2 $s3] == 0} \
then \
{ \
   puts "\"$s2\" equal \"$s3\""; \
} \
else \
{ \
   puts "\"$s2\" not equal \"$s3\""; \
};

"toto1" not equal "toto2"
"toto2" equal "toto2"

set ch "the computer is running for too long now - comp";
set m "comp";
set n [string first $m $ch];
puts "the match \"$m\" appears first at position $n";

the match "comp" appears first at position 4

set ch "the computer is running for too long now - comp";
set m "comp";
set n [string last $m $ch];
puts "the match \"$m\" appears last at position $n";

the match "comp" appears last at position 43

set ch "the computer is running for too long now - comp";
set m "comp";
set c [string wordend $ch 5];
puts "The index of the first character after word at index 5 is $c";

The index of the first character after word at index 5 is 12

set ch "the computer is running for too long now - comp";
set m "comp";
set c [string wordstart $ch 5];
puts "The index of the first character before word at index 5 is $c";

The index of the first character before word at index 5 is 4

set ch "the computer is running for too long now - comp";
set rc [string match "*computer*" $ch];
puts "rc = $rc";
if {$rc == 1} \
{ \
  puts "string ch contains match \"computer\""; \
} \
else \
{ \
  puts "string ch not contains match \"computer\""; \
};

string ch contains match "computer"


File


Open the file "c:\tmp\toto.txt" in read only mode. Read the content of the file (and place it into the variable buff). Then print buff and close the file.

set fd [open "c:/tmp/toto.txt" w];
set buff "exemple d'ecriture";
puts $fd "$buff"
close $fd;
Open the file "c:\tmp\toto.txt" in write mode only. Write the content of the buffer buff into the file. Then close the file.


Serial ports


set fd [open "com2" w];
set buff "exemple d'ecriture";
puts $fd "$buff"
close $fd;
com1 and com2 are connected with a null modem. The 2 serial ports have the same configuration (9600/8 bits/none/1 bits/none). On com1 we open a terminal.

Open serial port "com2". Write the content of the buffer buff into the port. Then close the serial port. We can see the data on the terminal.
set fd [open "com2" w];

fconfigure $fd -mode 9600,n,8,1
set buff "toto";
puts $fd $buff

close $fd;
Serial configuration:
  • 9600 baud
  • parity: none
  • 8 bits data
  • 1 stop bit

set fd [open "com2" r];

fconfigure $fd -mode 9600,n,8,1
set car [read $fd 1];
puts $car;

close $fd;
com1 and com2 are connected with a null modem. The 2 serial ports have the same configuration (9600/8 bits/none/1 bits/none). On com1 we open a terminal.

Open serial port "com2" for reading. read 1 character from the serial port. Then close the serial port.

Note: it is very important to give the 2 serial ports the same setting.
set fd [open "com2" r];
fconfigure $fd -mode 9600,n,8,1
set car "0"

while {$car != "s"} \
{ \
  set car [read $fd 1]; \
  puts $car; \
}

close $fd;
Same but with a "while" loop.


TK widgets


Buttons

# global variables
set number "0"

# callback
proc bouton_proc {} \
{ \
  global number; \
  set number [expr $number + 1]; \
  .bouton configure -text "$number"; \
}

# Tk GUI
button .bouton -text "$number" -command bouton_proc
pack .bouton



Each time you click on the button, the number value increases by 1.

Buttons

# global variables
set number "0"

# callbacks
proc bouton_proc {} \
{ \
  global number; \
  set number [expr $number + 1]; \
  .bouton configure -text "$number"; \
}

proc quit_proc {} \
{ \
  destroy .button .quit; \
  exit 0; \
}



# Tk GUI
button .bouton -text "$number" -command bouton_proc
button .quit -text "quit" -command quit_proc
pack .bouton .quit



When you press "quit" the application is destroyed. Note the a call to exit is enough.

Color image with labels

#callbacks
proc quit_proc {} \
{ \
  destroy .baner .quit; \
  exit 0; \
}


# Tk GUI
image create photo map -file imag.gif

label .baner -image map
button .quit -text "quit" -command quit_proc

pack .baner .quit

Color images and labels

# globals
set image_num "0";

#callbacks
proc quit_proc {} \
{ \
  destroy .baner .quit .change; \
  exit 0; \
}

proc change_proc {} \
{ \
  global image_num;

  if {$image_num == "0"} \
  then \
  { \
    .baner configure -image new_map; \
    set image_num "1"; \
  } \
  else \
  { \
    .baner configure -image map; \
    set image_num "0"; \
  } \
}


# Tk GUI
image create photo map -file imag.gif;
image create photo new_map -file new_imag.gif;

label .baner -image map;
button .change -text "change image" -command change_proc;
button .quit -text "quit" -command quit_proc;

pack .baner .quit .change;


Each time you click on "change image", you change the image.

Color image and canvas

# globals
set image_num "0";

#callbacks
proc quit_proc {} \
{ \
  destroy .baner .quit .change; \
  exit 0; \
}

proc change_proc {} \
{ \
  global image_num; \

  if {$image_num == "0"} \
  then \
  { \
    set image_num "1"; \
    .baner delete image_1; \
    .baner create image 50 25 -image \
           new_map -tag image_2; \
  } \
  else \
  { \
    set image_num "0"; \
    .baner delete image_2; \
    .baner create image 75 30 -image \
           map -tag image_1; \
  } \
}


# Images (items for the canvas)

image create photo map -file imag.gif;
image create photo new_map -file new_imag.gif;

# create the canvas and associate the items
# The identifier 'image_1' represents the image 'map'. Identifiers are
# used to access each part of the canvas.
# Note that the "origine" of the image is the center of the image (not
# the upper left coner !).

canvas .baner -width 150 -height 100;
.baner create image 75 30 -image map -tag image_1;

button .change -text "change image" -command change_proc;
button .quit -text "quit" -command quit_proc;

pack .baner .quit .change;


When you press the button "change image" the content of the canvas is modified.

Interacting with the canvans (moving tags)

# globals
set image_num "0";
set x_line_1 "75";

#callbacks
proc quit_proc {} \
{ \
  destroy .baner .quit .change .left . \
  exit 0; \
}

proc change_proc {} \
{ \
  global image_num; \

  if {$image_num == "0"} \
  then \
  { \
    set image_num "1"; \
    .baner delete image_1; \
    .baner create image 50 25 -image \
           new_map -tag image_2; \
  } \
  else \
  { \
    set image_num "0"; \
    .baner delete image_2; \
    .baner create image 75 30 -image \
           map -tag image_1; \
  } \
}

proc left_proc {} \
{ \
  global x_line_1;

  .baner delete line_1; \
  set x_line_1 [expr $x_line_1 + 3]; \
  .baner create line $x_line_1 0 \
     $x_line_1 60 -smooth on \
     -fill black -tag line_1; \
}


# create canvas tags
# - Images items for the canvas

image create photo map -file imag.gif;
image create photo new_map -file new_imag.gif;

# create the canvas and associate the items
# The identifier 'image_1' represents the image 'map'. Identifiers are
# used to access each part of the canvas.
# Note that the "origine" of the image is the center of the image (not
# the upper left coner !).

canvas .baner -width 150 -height 100;
.baner create image 75 30 -image map -tag image_1;
.baner create line 75 0 75 60 -smooth on -fill black -tag line_1
.baner create line 0 30 150 30 -smooth on -fill black -tag line_2

button .change -text "change image" -command change_proc;
button .left -text "left" -command left_proc;
button .quit -text "quit" -command quit_proc;

pack .baner .quit .change .left;


Same as previous but when you click on the buuton "left", the vertical line moves to the left.

Background procedure

# globals
set image_num "0";
set x_line_1 "75";

#callbacks
proc quit_proc {} \
{ \
  destroy .baner .quit .left . \
  exit 0; \
}

proc left_proc {} \
{ \
  global x_line_1;

  .baner delete line_1; \
  set x_line_1 [expr $x_line_1 + 3]; \
  .baner create line $x_line_1 0 \
     $x_line_1 60 -smooth on \
     -fill black -tag line_1; \

  after 1000 left_proc; \
}

proc stop_proc {} \
{ \
  after cancel left_proc; \
}

# create canvas tags
# - Images items for the canvas

image create photo map -file imag.gif;

# create the canvas and associate the items
# The identifier 'image_1' represents the image 'map'. Identifiers are
# used to access each part of the canvas.
# Note that the "origine" of the image is the center of the image (not
# the upper left coner !).

canvas .baner -width 150 -height 100;
.baner create image 75 30 -image map -tag image_1;
.baner create line 75 0 75 60 -smooth on -fill black -tag line_1

button .left -text "left" -command left_proc;
button .stop -text "stop" -command stop_proc;
button .quit -text "quit" -command quit_proc;

pack .baner .quit .left .stop;


When you press "left" the vertical line begins to move to the left and it keeps going until you press "stop".

Scrollbars and geometry managers

# globals
set image_num "0";

#callbacks
proc quit_proc {} \
{ \
  destroy .baner \
          .quit \
          .scroll_y \
          .scroll_x \
          . \
  exit 0; \
}

# Laod map and get properties (used to center the image)
image create photo map -file pays.gif;
set border 20
set max_x [image width map];
set max_y [image height map];
set pos_x [expr $max_x / 2 - [expr $border / 2]];
set pos_y [expr $max_y / 2 - [expr $border / 2]];
set canvas_width [expr $max_x + [expr $border / 2]];
set canvas_height [expr $max_y + [expr $border / 2]];
set Scrolling_Win "-30/-30/$canvas_width/$canvas_height"

# Create scrollbars and apply them to the canvas
scrollbar .scroll_x -command ".baner xview" -orient horizontal;
scrollbar .scroll_y -command ".baner yview" -orient vertical;

canvas .baner -relief sunken -borderwidth 2 \
       -width [expr $max_x + 10] \
       -height [expr $max_y + 10] \
       -scrollregion [split $Scrolling_Win /] \
       -xscrollcommand ".scroll_x set" \
       -yscrollcommand ".scroll_y set";

# apply the map into the canvas
.baner create image "$pos_x" "$pos_y" -image map -tag image_1;

button .quit -text "quit" -command quit_proc;
label .hauteur -text "$max_x x $max_y";

pack .quit -side bottom;
pack .scroll_y -side right -fill y;
pack .scroll_x -fill x;
pack .hauteur;
pack .baner;
pack .hauteur;

Serial port and timer

set fd [open "com2" r];
fconfigure $fd -mode 9600,n,8,1

proc quit_proc {} \
{ \
  global fd; \
  after cancel Read_Com; \
  close $fd; \
  destroy .text \
          .quit \
          .screen \
          .; \
  exit 0;
}

proc Read_Com {} \
{ \
  global fd; \

  set car "0"; \
  set car [read $fd 1]; \
  .text configure -text "$car"; \
  puts $car; \
  update; \

  after 1000 Read_Com;
}

button .quit -text "quit" -command quit_proc;
button .text -text "read" -command Read_Com;
label .screen -text "data";

pack .quit .text .screen;


com1 and com2 are connected with a null modem. The 2 serial ports have the same configuration (9600/8 bits/none/1 bits/none). On com1 we open a terminal.

If you click on "read" it opens the serial port "com2" for reading.
Then it reads 1 character from the serial port every second.

Keep in mind that the serial line is configured in "blocking mode": if there is no character to read, then the read operation blocks the process. The "update" command forces the refresh of the screen.