#!/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"

#!/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

#!/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} {
    set data [read stdin 4096]
    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

#!/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} {
    set sock [socket $addr $port]
    fconfigure $sock -buffering line
    set msg "Hello there sailor"

    while {$n} {
    puts $sock $msg
    if {[gets $sock] != $msg} {
        error "Received different message: $r."
    }
    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
}

#!/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

#!/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]

#!/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

#!/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

#!/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

#!/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"

#!/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

#!/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

#!/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

#!/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

#!/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

#!/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

#!/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"

#!/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

#!/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
    set nums [read stdin]
    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

#!/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]

#!/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

#!/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} {
    set data [read stdin 4096]
    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