puts "Hello world"
proc foo {} {puts Hello}
set s foo
$s
set q "puts {Hello world}"
{*}$q
puts "Content-type: text/html\r\n\r\n" puts "Hello world" die
Loop iterate variable i from 0 to 9 and print out
Shows the use of: option expression which modifes how flow-control commands handle arguments
option expression off
for {set i 0} {< $i 10} {incr i} {
puts "i is $i"
++ i
}
option expression on
for {set i 0} {$i < 10} {incr i} {
puts "i is $i"
++ i
}
set l {a b c d e f}
foreach {x y} $l {
puts "Multiple variables may be processed $x $y"
}
set a 22;set b 7.0;set p [expr $a/$b];puts "Pi is $p"
In Tcl, [set] is used either to assign or to echo a variable's contents
Each level of dereference called for [puts] is the same. $var is equivalent to [set var]
The variable chain runs: d -> c -> b -> a -> 23
set a 23 set b a set c b set d c puts $$$$d # 4 levels of dereference puts [set $$$d] # 4 levels of dereference puts [set [set $$d]] # 4 levels of dereference puts [set [set [set $d]]] # 4 levels of dereference puts [set [set [set [set d]]]] # 4 levels of dereference
The data file returns a list of pairs which can be used by [array set]
# Data file. include_data.tcl
return {
1 {foo}
2 {bar}
3 {baz}
4 {quux}
}
# Main file which will include the data file above
puts "Including include_data.tcl"
array set data [source include_data.tcl]
for {set i 1} {<= $i [array size data]} {++ i} {
puts "$data($i)"
}
The commands are similar to those available in C/C++
[readfile] is also available, which can read via a single command
set fp [file open [unescape $argv(1)]] set r [file gets $fp s 100] puts "s is '$s" file close $fp
puts [expr [<< [expr 20+3] [expr 2^4] 32] - 472] puts [expr 1*[<< 1 1]*3/4.0*5]
Note that these are exported [expr] functions, not commands. They are exported via [funct]
puts [funct log10 2] puts [funct round $pi 2] puts [funct rnd 1 10] puts [* [funct atan 1] 4]
[inkey] checks if a keystroke is available, if so, the key code is returned
puts "Press ESC to halt"
while {1} {
puts "Looping"
sleep 1000
if {== [inkey] 27} { # ESC is 27
stop
}
}
proc factorial {val} {
puts "Current level: [info level] - val: $val"
set lvl [info level]
if {$lvl == $val} {
return $val
}
return [expr {($val-$lvl) * [factorial $val]}]
}
puts [factorial 3]
option expression off
loop i 0 10 1 {
if {== $i 5} {
# Skip 5 and increment past 6
++ i
continue
}
}
puts "i is $i"
Will display: [- [+ [+ [* 4 4] [* 4 4]] 4] [* 4 4]]
Which is the same as [- [+ [+ 16 16] 4] 16]
Which is the same as: [- [+ 32 4] 16]
Which is the same as [- 36 16]
Which results in: 20
It is recursively evaluated in the order
[- [+ [+ 16 16] 4] [* 4 4]]
[- [+ 32 4] [* 4 4]]
[- 36 [* 4 4]]
[- 36 16]]
20
option preprocessor off puts [explain 4*4+4*4+4-4*4]
The defined
procedure will print "* Bye *" when a script exits
Note that there shoiuld be a space between ! and [defined]
if { ! [defined at_exit] } {
proc at_exit {} {
newline
textcolor yellow
puts "* Bye *"
textcolor
}
}
ticol.exe filename.tcl /c /64 is used to generate the code which will be saved as a *.t64 file. These files may also be read in using [readfile] and then executed using the TCX module
# Uses default encryption # Encode using ticol.exe filename.tcl /c and base64.exe filename.tcx set code "ibuhXiuUJYyD6Uubn7G4L/wRkK/BtOkaHi5IFuULSaPU/3YskM139 seIuesC7KEhQjprZY83PyZAqzgwFmlfnIkpMMmSMvs= # Load the plugin lib ticol_tcx # Execute the code (call [eval] internally) tcx run $code # Unload the plugin lib ticol_tcx -unload
Will return:
catlog
cd
title Empire Burlesque
artist Bob Dylan
Company Columbia
Price 10.90
year 1985
set l "{catlog {cd {{title {Empire Burlesque}} {artist {Bob Dylan}} \
{Company Columbia} {Price 10.90} {year 1985} }}}"
proc unwrap_as_text {l} {
global foo::s # Avoid clashes with root a namespace var
foreach x $l {
if {> [ldepth $l] 2} {
unwrap_as_text $x
} else {
append ::foo::s "$x\t"
}
}
if {<= [ldepth $l] 2} {
set ::foo::s [string trim $::foo::s "\t "]
append ::foo::s "\r\n"
}
}
unwrap_as_text $l
textcolor cyan
puts $foo::s
textcolor
There is nothing wrong with using a goto in the right place
option expression off
set s 0
goto_block {
start { # Loop start
++ s # Increment
if {> $s 9} { # Test
goto end # Exit
}
goto start # Loop end
}
end {
textcolor magenta
puts "Puts exited OK at label: end"
textcolor
}
}
Prints out.. e.g.
<html>
<head>
<title>
</title>
</head>
<body bgcolor="#000000" text="#C0C0C0" link="#00FFFF">
...
option expression off lib ticol_html set s [http http://localhost:8800] do { set t [html chomp_tag s] puts $t } while {ne $t ""}
For
me, this returns:
Filetype ".tcl" opens with "C:\Program Files
(x86)\Notepad++\notepad++.exe" "%1"
lib ticol_reg
set ext .tcl
# Read the type name
set type [registry get HKEY_CLASSES_ROOT\\$ext {}]
# Work out where to look for the command
set path HKEY_CLASSES_ROOT\\$type\\Shell\\Open\\command
# Read the command
set command [registry get $path {}]
puts "Filetype \"$ext\" opens with $command"
set seed $pi # Could instead use [clock]
set counter 0 # Global/static counter
option expression on # Use [expr] for flow-control
proc hashrnd {lo hi} { # Hash-generated random number
upvar seed # Not recursive. No level given
upvar counter
incr counter
set r [md5 [+ $counter $seed]] # Get an MD5 value
set q "0x" # Literal 0x prefix
append q [mids r [% $counter 24] 8] # Slice a section of the MD5
return [expr "$q % (($hi-$lo)+1)+$lo"] # Evaluate as hexadecimal
}
option expression on
for {set i 0} { $i < 10000} {incr i} {
puts "hashrnd 10..10000:\t[hashrnd 10 10000]"
}
The orange colouration is a custom colour set for darkyellow which can be set by Ticol (see console_orange.bat)
We use [calc] for maximum performance. This is a macro-stage optimising form of [expr] which will expand expresisions into inline Tcl prior to runtime and simplify arguments where possible
e.g. set t [calc ($a*$a)-($b*$b)+$ca] becomes
set t [+ [- [* $a $a] [* $b $b]] $ca]
option expression off
const print_numbers $false # Set to $true to print numbers in BASIC style
for {set y -12} {<= $y 12} {++ y} {
set print_space $true
puts " " -nonewline
for {set x -39} {<= $x 39} {++ x} {
set ca [* $x 0.0458]
set cb [* $y 0.08333]
set a $ca
set b $cb
for {set i 0} {<= $i 15} {++ i} {
set t [calc ($a*$a)-($b*$b)+$ca]
set b [calc (2*$a*$b)+$cb]
set a $t
if {> [calc ($a*$a)+($b*$b)] 4} {
if {> $i 9} {
+= i 7
}
textcolor [+ [% $i 7] 1]
if {$print_numbers} {
puts [chr [+ 48 $i]] -nonewline
} else {
puts [chr 0xdb] -nonewline
}
textcolor
set print_space $false
break
}
}
if {$print_space} {puts " " -nonewline}
set print_space $true
}
newline
}
Brainfuck is inefficient and performs a huge number of iterations on anything much larger than "Hello world"
This script defines a proc [array_to_string_asc] to convert the byte-array back to ASCII text
Makes use of enhanced [store] command as well as single-character [index]
Note that "[" and "]" must be stored in 'escaped' form within the Tcl string and the routine called using [unescape]. [switch] will compare using the -exact (default) option
Note the byte-width cropping for [++] and [--] when incrementing the tape contents. This is to keep the value within 0..255 ASCII range
Text-input for "," requires improvement
For full performance, Brainfuck would be need to be implemented as a plugin DLL
The same code, compiled in C++ as bf.exe is available for speed-comparison
option expression off
proc array_to_string_asc {arr} {
#################################################
# Convert an integer byte-array to ASCII string
#################################################
upvar $arr a
for {set i 0} {< $i [array size a]} {++ i} {
store add [chr $a($i)]
}
return [store get]
}
const MAX_NESTING 100
const MAX_TAPE 6000 # Size of the processing arena
const MAX_LOOPS 100000 # Infinite loop protection
proc bf {prog} {
set prog_len [string length $prog]
if {$prog_len} {
set output_len 0
dim tape $::MAX_TAPE
for {set i 0} {< $i $::MAX_TAPE} {++ i} {
set tape($i) 0
}
set edi 0
set eip 0
set loop_protection $::MAX_LOOPS
set depth 0
set state 0
dim loopstart 100
set loopstart(0) 0
set result(0) ""
set count 0
while {&& [< $eip $prog_len] [-- loop_protection]} {
if {strchr [unescape "<>+-.,[]"] [index $prog $eip]} {
++ count
switch [index $prog $eip] {
"<" { # < [chr 60] - decrement the data pointer
if {$edi} {
-- edi
}
}
">" # > [chr 62] - Increment the data pointer
if {< $edi $::MAX_TAPE} {
++ edi
}
}
"+" { # + [chr 43]
++ tape($edi) -width 8
}
"-" { # - [chr 45]
-- tape($edi) -width 8
}
"." { # "." [chr 46] - output the byte at the data pointer
set result($output_len) $tape($edi)
++ output_len
}
"," { # "," [chr 44] - Accept one byte of input
set tape($edi) [getkey]
}
"[" { # "[" [chr 91]
set state 1
if {== $tape($edi) 0} {
while {&& [!= $state 0] [< [++ eip] $prog_len]} {
if {eq [index $prog $eip] "]"} {
-- state
} elseif {eq [index $prog $eip] "["} {
++ state
}
}
} elseif {< $depth $::MAX_NESTING} {
set loopstart([++ depth]) $eip
}
}
"]" { # "]" [chr 93]
if {!= $depth 0} {
if {== $tape($edi) 0} {
-- depth
} else {
set eip $loopstart($depth)
}
}
}
}
}
++ eip
}
}
if {<= $loop_protection 0} {
puts "Error: Infinite loop detected"
die
}
return [array_to_string_asc result]
}
set s "
+++++ +++++ Iinitialise counter (c0) to 10
\[
> +++++ ++ Add 7 to cell #1
> +++++ +++++ Add 10 to cell #2
> +++ Add 3 to cell #3
> + Add 1 to cell #4
<<<< - Decrement counter (cell #0)
\]
> ++ . Print 'H'
> + . Print 'e'
+++++ ++ . Print 'l'
. Print 'l'
+++ . Print 'o'
> ++ . Print ' '
<< +++++ +++++ +++++ . Print 'W'
> . Print 'o'
+++ Print 'r'
----- - . Print 'l'
----- --- . Print 'd'
> + . Print '!'
> . Print '
'
"
puts [bf [unescape $s]]
option expression off
proc maze {width height {char "²"}} {
dim maze [* $width $height]
loop x 0 $width 1 {
loop y 0 $height 1 {
set maze($x,$y) " "
}
}
set currentx [int [* [funct rand] [- $width 1]]]
set currenty [int [* [funct rand] [- $height 1]]]
if {= [% $currentx 2] 0} {++ currentx}
if {= [% $currenty 2] 0} {++ currenty}
set maze($currentx,$currenty) $char
set done 0
set loops [* [* $width $height] 20]
while {! $done} {
loop i 0 $loops {
set oldx $currentx
set oldy $currenty
set j [rnd 0 3]
if {== $j 0} {
if {< [+ $currentx 2] $width} {++ currentx 2}
} elseif {== $j 1} {
if {< [+ $currenty 2] $height} {++ currenty 2}
} elseif {== $j 2} {
if {> [- $currentx 2] 0} {-- currentx 2}
} elseif {== $j 3} {
if {> [- $currenty 2] 0} {-- currenty 2}
}
if {eq $maze($currentx,$currenty) " "} {
set maze($currentx,$currenty) $char
set maze([/ [+ $currentx $oldx] 2],[/ [+ $currenty $oldy] 2]) $char
}
}
set done 1
}
loop y 0 $height {
loop x 0 $width {
puts $maze($x,$y) -nonewline
}
newline
}
}
maze 40 30 *
This shows struct, const and enum declaration as well as the use of a base struct as a typdef using [new]
Returns
* "Distributed Link Tracking Client" Running? true
* "No Such Service FooBar" Running? false
* "Themes" Running? true
|
option escape on
lib ticol_calldll -nocomplain
newline
struct type_service_status { # Can be used as a typedef with [new]
{dwServiceType 4}
{dwCurrentState 4}
{dwControlsAccepted 4}
{dwWin32ExitCode 4}
{dwServiceSpecificExitCode 4}
{dwCheckPoint 4}
{dwWaitHint 4}
}
enum {
SERVICE_STATUS_UNKNOWN # 0
SERVICE_STOPPED # 1
SERVICE_START_PENDING # 2
SERVICE_STOP_PENDING # 3
SERVICE_RUNNING # 4
SERVICE_CONTINUE_PENDING # 5
SERVICE_PAUSE_PENDING # 6
SERVICE_PAUSED # 7
}
const SC_MANAGER_ENUMERATE_SERVICE 0x0004
struct service_status {
{dwServiceType 4}
{dwCurrentState 4}
{dwControlsAccepted 4}
{dwWin32ExitCode 4}
{dwServiceSpecificExitCode 4}
{dwCheckPoint 4}
{dwWaitHint 4}
}
if {! [defined is_service_running]} {
proc is_service_running {service_name} {
#############################################################
# Query a service by name
#############################################################
# [in] Registered service name
# Note: Not the descriptive name
# [return] Boolean status value
#############################################################
option expression push on
upvar true
upvar false
set r $false
new ::type_service_status ss
set scm_handle [calldll Advapi32 OpenSCManagerA [info hostname] 0 $::SC_MANAGER_ENUMERATE_SERVICE]
if {$scm_handle > 0} {
set sc_handle [calldll Advapi32 OpenServiceA $scm_handle $service_name $::SC_MANAGER_ENUMERATE_SERVICE]
if {$sc_handle > 0} {
set r [calldll Advapi32 QueryServiceStatus $sc_handle ss]
calldll Advapi32 CloseServiceHandle $sc_handle
if {[ofaddressb ss.dwCurrentState] == $::SERVICE_RUNNING} {
set r $true
}
}
calldll Advapi32 CloseServiceHandle $scm_handle
}
option expression pop
return $r
}
}
textcolor white darkmagenta
puts " * "Distributed Link Tracking Client" Running? [bool [is_service_running {trkwks}]]"
puts " * "No Such Service FooBar" Running? [bool [is_service_running {FooBar}]]"
puts " * "Themes" Running? [bool [is_service_running {Themes}]]" -nonewline
textcolor
newline
<!- Web form -->
<html><head><title>Test Form</title></head>
<body><pre><form name="A" method="POST"
action="/cgi-bin/ticol.exe?cgi_post.tcl"
enctype="multipart/form-data"
encoding="multipart/form-data"><p>
Enter your name: <input type="text" name="name"
size="30"><p>
Enter some text: <input type="text" name="text"
size="40"><p>
<input type="submit" value="Submit"
name="button1">
<input type="reset" value="Reset"
name="button2"><p>
</form></pre></body>
</html>
option expression off
puts "Content-type: text/html\r\n\r\n" # Be sure to send this first
lib ticol_cgi -nocomplain
set s [cgi] # Call to set $_POST
if {> $s 0} { # Test for -ve error return
puts "<font color="blue"><strong>"
array foreach _POST val subscript {
puts "<br>Result $_POST($subscript)='$val'<br>"
}
puts "</strong></font>"
}
lib ticol_ansi set s [readfile art.ans] ansi $s -fix lib ticol_ansi -unload
A more extensive example. Being highly-iterative, this is vastly slower than the identical, compiled C++ hanoi.exe example available here for comparison
This runs in about 4 seconds for 17 rings on an old-generation i5 with several other items multi-tasking
The compiled C+ exe version of the same code takes 68ms for 17 rings. Any iterative intensive code which runs outside of a Ticol native command will run a couple of orders of magnitude slower than compiled code. Since DLL plugins are quite easy to produce with the quickest time to create a plugin being about 20 minutes, I would move any frequently used or computationally-intensive code into a separate plugin command
option expression off cls set n 0 set yloc 1
if {! [defined draw_status]} {
proc draw_status {} {
upvar yloc
gotoxy 1 $yloc
upvar a
upvar b
upvar c
upvar n
upvar moves
upvar x
textcolor white
puts "Towers of Hanoi ($n) - Pole Status ([comma $x] moves)\n"
textcolor red
printf "Pole A(%2i) %-67s\r\n" [stack count a] [stack list a]
textcolor yellow
printf "Pole B(%2i) %-67s\r\n" [stack count b] [stack list b]
textcolor green
printf "Pole C(%2i) %-67s\r\n" [stack count c] [stack list c]
textcolor
}
}
textcolor white blue
puts " Towers of Hanoi "
textcolor
newline
if {[< $argc 2]} {
puts "How many rings (2..25)? " -nonewline
gets stdin n
if {|| [== $n ""] [== $n 0]} {stop}
} else {
set n $argv(1)
}
set n [min $n 25]
stack create a $n # Init 3 stacks to given size
stack create b $n
stack create c $n
for {set x 0} {[< $x $n ]} {++ x} { # Create initial stack of hoops
stack push a [+ $x 1] # 0..n-1
}
set x 1
set shln [<< 1 $n] # Precalc (1 << $n), << for n
draw_status
set start_secs [clock seconds]
set start [timer]
while {< $x $shln} {
set xminus1 [- $x 1]
stack push [chr [calc ((($x|$xminus1) + 1) % 3 )] 97] \
[stack pop [chr [calc ($x & $xminus1) % 3] 97]]
is_mod $x 50000 draw_status
++ x
}
set end [timer]
set end_secs [clock seconds]
draw_status
newline
puts "Took [- $end $start] millisecond(s) and [comma $x] move(s)"
puts "Took [- $end_secs $start_secs] second(s) and [comma $x] move(s)"
newline
puts "Done."
stack unset a
stack unset b
stack unset c
Loop: 1
Loop: 2
Loop: 3
Loop: 4
lib ticol_asm # Load the interpreter plugin
asm {
org 100h ; Example only, not required
; as we won't JMP < 0x100
msg: ; Declare a variable/label
buf: ; Declare a variable/label
db ? "" ; Ensure AX is not printable on return mov msg, edp ; msg points to this string (EDP) db ? "Loop: " ; Define a string (6 bytes+null) mov buf, edp ; buf points to EDP db 21, 0 ; 21 byte buffer to store number mov ax, 4 ; Initialise AX mov bx, 0 ; Initialise BX to counter
L1: ; Declare a label push ax ; Save AX mov ax, msg ; Point AX to our message call 9 ; Print string inc bx ; Increment BX mov [buf], bx ; Store BX value in our buffer mov ax, buf ; Point AX to our printable buffer call 9 ; Call print address at AX mov ax, 10 ; CR (newline) call 2 ; Call print char pop ax ; Restore AX dec ax ; Decrement AX jnz L1 ; If not zero then loop L1 xor ax, ax ; Clear AX end ; Finish } lib ticol_asm -unload # Unload the interpreter plugin