[The Original Shootout]   [NEWS]   [FAQ]   [Methodology]   [Platform Details]   [Acknowledgements]   [Scorecard]
All Source For tcl
Ackermann's Function
```#!/usr/local/bin/tclsh
# \$Id: ackermann.tcl,v 1.3 2000/12/30 18:58:30 doug Exp \$
# http://www.bagley.org/~doug/shootout/

set NUM [lindex \$argv 0]
if {\$NUM < 1} {
set NUM 1
}

proc ack {m n} {
if {\$m == 0} {
return [expr {\$n + 1}]
} elseif {\$n == 0} {
return [ack [expr {\$m - 1}] 1]
} else {
return [ack [expr {\$m - 1}] [ack \$m [expr {\$n - 1}]]]
}
}

set ack [ack 3 \$NUM]
puts "Ack(3,\$NUM): \$ack"
```
Array Access
```#!/usr/local/bin/tclsh
# \$Id: ary3.tcl,v 1.1 2001/05/31 02:27:48 doug Exp \$
# http://www.bagley.org/~doug/shootout/

# this program is modified from:
#   http://cm.bell-labs.com/cm/cs/who/bwk/interps/pap.html
# Timing Trials, or, the Trials of Timing: Experiments with Scripting
# and User-Interface Languages</a> by Brian W. Kernighan and
# Christopher J. Van Wyk.

proc main {} {
global argv
set n [lindex \$argv 0]
set last [expr {\$n - 1}]
for {set i 0} {\$i < \$n} {incr i} {
set x(\$i) [expr {\$i + 1}]
set y(\$i) 0
}
for {set k 0} {\$k < 1000} {incr k} {
for {set j \$last} {\$j >= 0} {incr j -1} {
set y(\$j) [expr {\$x(\$j) + \$y(\$j)}]
}
}
puts "\$y(0) \$y(\$last)"
}

main
```
Count Lines/Words/Chars
```#!/usr/local/bin/tclsh
# \$Id: wc.tcl,v 1.5 2001/05/17 15:44:09 doug Exp \$
# http://www.bagley.org/~doug/shootout/

# this program is modified from:
#   http://cm.bell-labs.com/cm/cs/who/bwk/interps/pap.html
# Timing Trials, or, the Trials of Timing: Experiments with Scripting
# and User-Interface Languages</a> by Brian W. Kernighan and
# Christopher J. Van Wyk.

# Modified by Miguel Sofer and Jeff Hobbs

proc main {} {
set nl 0
set nc 0
set nw 0

set map [list \" x \{ x \} x]
while {1} {
if {![string length \$data]} {break}
if {[gets stdin extra] >= 0} {
append data \$extra
incr nc
}
incr nc [string length \$data]
incr nw [llength [string map \$map \$data]]
incr nl [llength [split \$data "\n"]]
}
puts "\$nl \$nw \$nc"
}

main
```
Echo Client/Server
```#!/usr/local/bin/tclsh
# \$Id: echo.tcl,v 1.1 2001/03/02 04:05:06 doug Exp \$
# http://www.bagley.org/~doug/shootout/

# from: Kristoffer Lawson

proc newClient {sock addr port} {
fconfigure \$sock -buffering line
set r [gets \$sock]
set rLength 0
while {![eof \$sock]} {
incr rLength [string length \$r]
# Extra increase because [gets] doesn't return \n
incr rLength
puts \$sock \$r
set r [gets \$sock]
}
puts "server processed \$rLength bytes"
exit
}

proc runClient {n addr port} {
fconfigure \$sock -buffering line
set msg "Hello there sailor"

while {\$n} {
puts \$sock \$msg
if {[gets \$sock] != \$msg} {
}
incr n -1
}
}

set n [lindex \$argv 0]

if {[llength \$argv] < 2} {
socket -server newClient 10000
exec tclsh83 [info script] \$n client &
vwait forever
} else {
runClient \$n localhost 10000
}

```
Exception Mechanisms
```#!/usr/local/bin/tclsh
# \$Id: except.tcl,v 1.5 2001/07/13 02:49:42 doug Exp \$
# http://www.bagley.org/~doug/shootout/
# with help from Kristoffer Lawson
# modified by Miguel Sofer

set HI 0
set LO 0

proc some_function {num} {
if {[catch {hi_function \$num} result]} {
puts stderr "We shouldn't get here (\$result)"
}
}

proc hi_function {num} {
if {[set exc [catch {lo_function \$num}]] == 11} {
# handle
incr ::HI
} else {
# rethrow
return -code \$exc
}
}

proc lo_function {num} {
if {[set exc [catch {blowup \$num}]] == 10} {
# handle
incr ::LO
} else {
# rethrow
return -code \$exc
}
}

proc blowup {num} {
if {\$num % 2} {
#error "Lo_exception"
return -code 10
} else {
#error "Hi_exception"
return -code 11
}
}

proc main {} {
global argv HI LO
set NUM [lindex \$argv 0]
if {\$NUM < 1} {
set NUM 1
}
incr NUM
while {[incr NUM -1]} {
some_function \$NUM
}
puts "Exceptions: HI=\$HI / LO=\$LO"
}

main
```
Fibonacci Numbers
```#!/usr/local/bin/tclsh
# \$Id: fibo.tcl,v 1.4 2000/12/30 17:35:51 doug Exp \$
# http://www.bagley.org/~doug/shootout/

# with help from: Kristoffer Lawson

proc fib {n} {
if {\$n < 2} {
return 1
} else {
return [expr {[fib [expr {\$n-2}]] + [fib [expr {\$n-1}]]}]
}
}

set N [lindex \$argv 0]
if {\$N < 1} { set N 1 }
puts [fib \$N]
```
Hash (Associative Array) Access
```#!/usr/local/bin/tclsh
# \$Id: hash.tcl,v 1.4 2001/05/02 05:32:39 doug Exp \$
# http://www.bagley.org/~doug/shootout/

# this program is modified from:
#   http://cm.bell-labs.com/cm/cs/who/bwk/interps/pap.html
# Timing Trials, or, the Trials of Timing: Experiments with Scripting
# and User-Interface Languages</a> by Brian W. Kernighan and
# Christopher J. Van Wyk.

proc main {} {
global argv
set n [lindex \$argv 0]
for {set i 1} {\$i <= \$n} {incr i} {
set x([format {%x} \$i]) \$i
}
set c 0
for {set i \$n} {\$i > 0} {incr i -1} {
if {[info exists x(\$i)]} {
incr c
}
}
puts \$c
}

main
```
Hashes, Part II
```#!/usr/local/bin/tclsh
# \$Id: hash2.tcl,v 1.6 2001/05/18 06:35:40 doug Exp \$
# http://www.bagley.org/~doug/shootout/
# with help from Branko Vesligaj

proc main {} {
global argv
set n [lindex \$argv 0]
for {set i 0} {\$i < 10000} {incr i} {
set hash1(foo_\$i) \$i
}
for {set i \$n} {\$i > 0} {incr i -1} {
foreach k [array names hash1] {
if {[catch {set hash2(\$k) [expr {\$hash1(\$k) + \$hash2(\$k)}]}]} {
set hash2(\$k) \$hash1(\$k)
}
}
}
puts [join [list \$hash1(foo_1) \$hash1(foo_9999) \$hash2(foo_1) \$hash2(foo_9999) ] " "]
}

main
```
Heapsort
```#!/usr/local/bin/tclsh
# \$Id: heapsort.tcl,v 1.4 2001/05/08 02:46:59 doug Exp \$
# http://www.bagley.org/~doug/shootout/
# sped up by Miguel Sofer's function generator

set IM 139968
set IA   3877
set IC  29573

set last 42

proc make_gen_random {} {
global IM IA IC
set params [list IM \$IM IA \$IA IC \$IC]
set body [string map \$params {
global last
expr {(\$max * [set last [expr {(\$last * IA + IC) % IM}]]) / IM}
}]
proc gen_random {max} \$body
}

proc heapsort {n ra_name} {
upvar \$ra_name ra

set j 0
set i 0
set rra 0.0
set l [expr {(\$n >> 1) + 1}]
set ir \$n
while 1 {
if {\$l > 1} {
incr l -1
set rra \$ra(\$l)
} else {
set rra \$ra(\$ir)
set ra(\$ir) \$ra(1)
incr ir -1
if {\$ir == 1} {
set ra(1) \$rra
return
}
}
set i \$l
set j [expr {\$l << 1}]
while {\$j <= \$ir} {
if {(\$j < \$ir) && (\$ra(\$j) < \$ra([expr {\$j + 1}]))} {
incr j
}
if {\$rra < \$ra(\$j)} {
set ra(\$i) \$ra(\$j)
set i \$j
set j [expr {\$j + \$i}]
} else {
set j [expr {\$ir + 1}]
}
}
set ra(\$i) \$rra
}
}

proc main {} {
global argv
set n [lindex \$argv 0]
make_gen_random

for {set i 1} {\$i <= \$n} {incr i} {
set ary(\$i) [gen_random 1.0]
}
heapsort \$n ary
puts [format "%.10g" \$ary(\$n)]
}

main
```
Hello World
```#!/usr/local/bin/tclsh
# \$Id: hello.tcl,v 1.1 2001/06/17 22:00:34 doug Exp \$
# http://www.bagley.org/~doug/shootout/

puts "hello world"
```
List Operations
```#!/usr/local/bin/tclsh
# \$Id: lists.tcl,v 1.3 2001/04/26 05:29:56 doug Exp \$
# http://www.bagley.org/~doug/shootout/
# from Kristoffer Lawson
# Modified by Tom Wilkason

set SIZE 10000

proc K {a b} {set a}

proc ldelete {listName index} {
upvar \$listName list
;# Replace a deletion with null, much faster
set list [lreplace [K \$list [set list {}]] \$index \$index]
}

proc lreverse {_list} {
upvar \$_list List
for {set i [expr {[llength \$List] - 1}]} {\$i >= 0} {incr i -1} {
lappend Li1r [lindex \$List \$i]
}
set List \$Li1r
unset Li1r
}

proc test_lists {args} {
# create a list of integers (Li1) from 1 to SIZE
for {set i 1} {\$i <= \$::SIZE} {incr i} {lappend Li1 \$i}
# copy the list to Li2 (not by individual items)
set Li2 \$Li1
# remove each individual item from left side of Li2 and
# append to right side of Li3 (preserving order)
lreverse Li2
foreach {item} \$Li2 {
lappend Li3 [lindex \$Li2 end]
ldelete Li2 end
}
# Li2 must now be empty
# remove each individual item from right side of Li3 and
# append to right side of Li2 (reversing list)
foreach {item} \$Li3 {
lappend Li2 [lindex \$Li3 end]
ldelete Li3 end
}
# Li3 must now be empty
# reverse Li1 in place
lreverse Li1
# check that first item is now SIZE
if {[lindex \$Li1 0] != \$::SIZE} {
return "fail size [lindex \$Li1 0]"
}
# compare Li1 and Li2 for equality
# and return length of the list
if {\$Li1 == \$Li2} {
return [llength \$Li1]
} else {
return "fail compare"
}
}

proc main {args} {
global argv
set NUM [lindex \$argv 0]
if {\$NUM < 1} {
set NUM 1
}
while {\$NUM > 0} {
set result [test_lists]
incr NUM -1
}
puts \$result
}

main
```
Matrix Multiplication
```#!/usr/local/bin/tclsh
# \$Id: matrix.tcl,v 1.6 2001/01/16 00:34:18 doug Exp \$
# http://www.bagley.org/~doug/shootout/

# This program based on the original from:
# "The What, Why, Who, and Where of Python" By Aaron R. Watters
# http://www.networkcomputing.com/unixworld/tutorial/005/005.html

# modified to avoid matrix size checks
# --Doug

# additional speedups by Kristoffer Lawson and Miguel Sofer

set size 30;

proc mkmatrix {rows cols} {
set count 1;
set mx [list]
for { set i 0 } { \$i < \$rows } { incr i } {
set row [list]
for { set j 0 } { \$j < \$cols } { incr j } {
lappend row \$count;
incr count;
}
lappend mx \$row;
}
return \$mx;
}

proc mmult {m1 m2} {
set cols [lindex \$m2 0]
foreach row1 \$m1 {
set row [list]
set i 0
foreach - \$cols {
set elem 0
foreach elem1 \$row1 row2 \$m2 {
set elem [expr {\$elem + \$elem1 * [lindex \$row2 \$i]}]
}
lappend row \$elem
incr i
}
lappend result \$row
}
return \$result
}

proc main {} {
global argv size
set num [lindex \$argv 0]
if {\$num < 1} {
set num 1
}

set m1 [mkmatrix \$size \$size]
set m2 [mkmatrix \$size \$size]
while {\$num > 0} {
incr num -1
set m [mmult \$m1 \$m2]
}

puts "[lindex [lindex \$m 0] 0] [lindex [lindex \$m 2] 3] [lindex [lindex \$m 3] 2] [lindex [lindex \$m 4] 4]"
}

main
```
Nested Loops
```#!/usr/local/bin/tclsh
# \$Id: nestedloop.tcl,v 1.2 2001/02/04 15:00:04 doug Exp \$
# http://www.bagley.org/~doug/shootout/
# from Tom Wilkason

proc main {} {
global argv
set n [lindex \$argv 0]
set x 0
incr n 1
set a \$n
while {[incr a -1]} {
set b \$n
while {[incr b -1]} {
set c \$n
while {[incr c -1]} {
set d \$n
while {[incr d -1]} {
set e \$n
while {[incr e -1]} {
set f \$n
while {[incr f -1]} {
incr x
}
}
}
}
}
}
puts \$x
}

main
```
Random Number Generator
```#!/usr/local/bin/tclsh
# \$Id: random.tcl,v 1.7 2001/05/08 01:36:50 doug Exp \$
# http://www.bagley.org/~doug/shootout/
# from Miguel Sofer

trace variable params w make_main
proc make_main {args} {
global params last
set randBody [string map \$params {
expr {(100.0 * [set last [expr {(\$last * IA + IC) % IM}]]) / IM}
}]
set mainBody [string map [list randBody \$randBody] {
global argv last
set N [lindex \$argv 0]
set result 0.0
while {\$N} {
set result [randBody]
incr N -1
}
puts [format "%.9f" \$result]
}]
proc main {} \$mainBody
}

set params {IM 139968 IA 3877 IC 29573}
set last 42

main
```
Regular Expression Matching
```#!/usr/local/bin/tclsh
# \$Id: regexmatch.tcl,v 1.9 2001/03/15 17:01:52 doug Exp \$
# http://www.bagley.org/~doug/shootout/
# from: Miguel Sofer, with modifications by Kristoffer Lawson

proc main {} {
global argv
set NUM [lindex \$argv 0]
if {\$NUM < 1} {
set NUM 1
}

set phones [split [read stdin] "\n"]
set count 0
set rExp {(?:^|[^\d(])(\(\d{3}\)|\d{3}) (\d{3})[ -](\d{4})(\$|[^\d])}

while {\$NUM > 0} {
incr NUM -1
foreach phone \$phones {
if {[regexp \$rExp \$phone match area exch num]} {
if {! \$NUM} {
incr count 1
puts "\$count: ([string trim \$area () ]) \$exch-\$num"
}
}
}
}
}

main
```
Reverse a File
```#!/usr/local/bin/tclsh
# \$Id: reversefile.tcl,v 1.5 2001/01/16 00:47:41 doug Exp \$
# http://www.bagley.org/~doug/shootout/
# from: Miguel Sofer

proc main {} {
set lines [split [read stdin] "\n"]

fconfigure stdout -buffering full

for {set i [expr {[llength \$lines]-2}]} {\$i >= 0} {incr i -1} {
puts [lindex \$lines \$i]
}
}

main
```
Sieve of Erathostenes
```#!/usr/local/bin/tclsh
# \$Id: sieve.tcl,v 1.9 2001/05/06 04:37:45 doug Exp \$
# http://www.bagley.org/~doug/shootout/
# with help from: Kristoffer Lawson

proc sieve {num} {
while {\$num > 0} {
incr num -1
set count 0
for {set i 2} {\$i <= 8192} {incr i 1} {
set flags(\$i) 1
}
for {set i 2} {\$i <= 8192} {incr i 1} {
if {\$flags(\$i) == 1} {
# remove all multiples of prime: i
for {set k [expr {\$i+\$i}]} {\$k <= 8192} {incr k \$i} {
set flags(\$k) 0
}
incr count 1
}
}
}
return \$count
}

set NUM [lindex \$argv 0]
if {\$NUM < 1} {
set NUM 1
}

set count [sieve \$NUM]
puts "Count: \$count"
```
Spell Checker
```#!/usr/local/bin/tclsh
# \$Id: spellcheck.tcl,v 1.9 2001/07/12 12:13:56 doug Exp \$
# http://www.bagley.org/~doug/shootout/
# from: Miguel Sofer
# some modifications suggested by Kristoffer Lawson

proc main {} {
set 1 [open "Usr.Dict.Words" r]
foreach  2 [read \$1 [file size "Usr.Dict.Words"]] {
set \$2 1
}
close \$1

fconfigure stdout -buffering full
while {[gets stdin 1] >= 0} {
if {[catch {set \$1}]} {
puts \$1
}
}
}

main
```
Statistical Moments
```#!/usr/local/bin/tclsh
# \$Id: moments.tcl,v 1.3 2001/01/05 22:11:27 doug Exp \$
# http://www.bagley.org/~doug/shootout/

proc main {} {
set sum 0.0
foreach num \$nums {
set sum [expr {\$sum + \$num}]
}
set n [llength \$nums]
set mean [expr {\$sum / \$n}]
set average_deviation 0.0
set standard_deviation 0.0
set variance 0.0
set skew 0.0
set kurtosis 0.0

foreach num \$nums {
set deviation [expr {\$num - \$mean}]
set average_deviation [expr {\$average_deviation + abs(\$deviation)}]
set variance [expr {\$variance + pow(\$deviation, 2)}]
set skew [expr {\$skew + pow(\$skew, 3)}]
set kurtosis [expr {\$kurtosis + pow(\$deviation, 4)}]
}

set average_deviation [expr {\$average_deviation / \$n}]
set variance [expr {\$variance / (\$n - 1)}]
set standard_deviation [expr {sqrt(\$variance)}]

if {\$variance} {
set skew [expr {\$skew / (\$n * \$variance * \$standard_deviation)}]
set kurtosis [expr {\$kurtosis / (\$n * \$variance * \$variance) - 3.0}]
}

set nums [lsort -integer \$nums]
set mid [expr {int(\$n / 2)}]
if [expr {\$n % 2}] {
set median [lindex \$nums \$mid]
} else {
set a [lindex \$nums \$mid]
set b [lindex \$nums [expr {\$mid - 1}]]
set median [expr {(\$a + \$b) / 2.0}]
}

puts [format "n:                  %d" \$n]
puts [format "median:             %f" \$median]
puts [format "mean:               %f" \$mean]
puts [format "average_deviation:  %f" \$average_deviation]
puts [format "standard_deviation: %f" \$standard_deviation]
puts [format "variance:           %f" \$variance]
puts [format "skew:               %f" \$skew]
puts [format "kurtosis:           %f" \$kurtosis]
}

main
```
String Concatenation
```#!/usr/local/bin/tclsh
# \$Id: strcat.tcl,v 1.4 2001/02/22 01:31:21 doug Exp \$
# http://www.bagley.org/~doug/shootout/
# from: Kristoffer Lawson

proc main {n} {
incr n
while {[incr n -1]} {
append str "hello\n"
}
puts [string length \$str]
}

main [lindex \$argv 0]
```
Sum a Column of Integers
```#!/usr/local/bin/tclsh
# \$Id: sumcol.tcl,v 1.5 2001/01/04 22:42:49 doug Exp \$
# http://www.bagley.org/~doug/shootout/
# from: Miguel Sofer

proc main {} {
set sum 0
while {[gets stdin line]> 0} {
incr sum \$line
}
puts \$sum
}

main
```
Word Frequency Count
```#!/usr/local/bin/tclsh
# \$Id: wordfreq.tcl,v 1.11 2001/05/17 00:49:34 doug Exp \$
# http://www.bagley.org/~doug/shootout/
# with help from: Tom Wilkason and Branko Vesligaj

proc main {} {
while {1} {
if {[string equal \$data {}]} {break}
if {[gets stdin extra] >= 0} {
append data \$extra
}
regsub -all  {[^[:alpha:]]+} \$data { } line
foreach word [string tolower \$line] {
if {[catch {incr count(\$word)}]} {
set count(\$word) 1
}
}
}
foreach {word cnt}  [array get count] {
lappend lines [format "%7d\t%s" \$cnt \$word]
}
puts [join [lsort -decreasing \$lines] "\n"]
}

main

```