Bag of algorithms

Here's some "few-liner" code examples, contributed by Richard Suchenwirth, <YOUR NAME HERE>, ... . Help yourself! Add comments when you know it better! Use the Edit link at bottom of page for contributing! Short procs (fitting between thumb and index finger ;-) go right here, longer ones get their own pages and are linked on this page.

1-Bits in a positive int

See Bit Twiddling

ASCII map

see Additional string functions

A simple Arabic renderer

Arabic from ASCII transliteration (Buckwalter) to Unicode, from abstract characters to glyphs

Application home

Find the real/exact/full path of the running script

proc app_home {} {
    set old_dir [pwd]
    set f      $::argv0
    set f_path [file dirname $f]
    set f_tail [file tail $f]
    cd  $f_path
    set f $f_tail
    while {![catch {file readlink $f} result]} {
        cd [file dirname $result]
        set f_path [pwd]   ;# pwd makes path absolute
        set f_file [file tail $result]
        set f [file join $f_path $f_file]
    }
    cd $old_dir
    return $f_path
}

I can not remember where I took this originally from. Sorry Andreas Wilm

Lars H: Here is another approach to the above, which also returns the list of all "home" directories (a link may point to another link, and then to yet another, etc.)

proc app_homes {} {
    set res [list]
    set me [info script]
    catch {
       while {1} {
          set mydir [file dirname $me]
          lappend res $mydir
          set me [file join $mydir [file readlink $me]]
       }; # Eventually the [file readlink] errors
    }
    return $res
}

It could probably do with some file normalizes. However, a comparison of $::argv0 and [info script] from a portability perspective could be interesting.

SG: I'm probably just missing something (I usually do) but what does any of this do that pwd doesn't?

Lars H: Lots of things. For one, the script might have been started as

% tclsh /full/path/to/script.tcl

For another, the script might have been marked executable and was found by a search along the PATH. There is no relation between the result of pwd and the script location in either of these cases.

Array-preserving Order of Elements

if you want to keep a history in what sequence

array elements were added, have a look at Numbered arrays

Assertions

can be implemented in millions of ways, here is one:

proc Assert {condition} {
    if {[catch {uplevel [list expr $condition]} n] || $n == "" || $n == 0} {
        Puts "Assertion failed (result $n), in:"
        set prefix ""
        for {set i [info level]} {$i} {incr i -1} {
            append prefix "  "
            puts "$prefix'[info level $i]'"
        }
            # try to call a failure handler to collect more info
        if {![catch ::AssertionFailureHandler msg] && $msg != ""} {
            append condition " ($msg)"
        }
        #error "Assertion failed: $condition"
        puts "Assertion failed: $condition"
        exit
    }
} ;# JCW

And of course disabled simply by overriding the above definition with "proc Assert {x} {}".

AtExit Handlers

cleanup on program exit for you.

Autokill

kill an application after a resettable delay:

proc autokill {delay {id ""}} {
    if {$id != ""} {after cancel $id}
    set id [after [expr int($delay * 1000 * 60)] {exit}]
    proc autokill "[list delay [list id $id]]" [info body autokill]
}
autokill 30; #exit after a 30 minute delay

call it again, the same way to reset the timer. Useful in situations where an application uses a lot of network resources, and has the potential for a user to leave it running while not in use. -- AJB

automatic .bak files

automatically backs up files N levels deep to avoid overwrites

Average

See Additional math functions

Base 64 encode/decode

shamelessly stolen from Steve Uhler and Brent Welch

Cartesian product of a list of lists

Character frequency counts

see tally: a string counter gadget

Clock clicks resolution

Unlike most time-related things handled by Tcl, the unit of the value returned by clock clicks is documented to be platform-dependent (even though the microsecond is very frequent), so it might be good to check roughly how many clicks there are in a second. The following one-liner will do that:

expr {-[clock clicks] + [after 1000; clock clicks]}

configuration files

this proc can be added to an application

proc configfile {name} {
    global $name
    set data [read [set fh [open [info script] r]]]
    close $fh
    array set $name $data
    catch {unset ${name}(configfile) ${name}(#)}
    return -code return
}

and then at the top of a file you wish to be loaded as a configuration file simply add configfile var

of course you must load the file

if {[catch {source myconfigfile} err]} {
    # some error occured
}

the contents of the file then end up in global variable var

an example file:

configfile options
setting value
setting2 {some large value}

this was developed for Easy User Configurable Menus

Compact integer list to list

{1-4 6-8} => {1 2 3 4 6 7 8}

proc clist2list {clist} {
    #-- clist: compact integer list w.ranges, e.g. {1-5 7 9-11}
    set res {}
    foreach i $clist {
        if [regexp {([^-]+)-([^-]+)} $i -> from to] {
            for {set j [expr $from]} {$j<=[expr $to]} {incr j} {
                lappend res $j
            }
        } else {lappend res [expr $i]}
    }
    return $res
} ;#RS

Compact list to list

{2-4 a c-e A C-E} => {2 3 4 a c d e A C D E}

As above, this one handles a-z and A-Z as well as the proposed 0-9.

proc clist2list {{args ""}} {
    if {[llength $args] != 1} {
        error {wrong # args: should be "clist2list clist"}
    }
    set clist [lindex $args 0]
 
    # Ensure clist is in list format, if not then make it so.
    if {[catch {llength $clist}]} {set clist [split $clist]}
 
    array set map [list \
        a  1   b  2   c  3   d  4   e  5 \
        f  6   g  7   h  8   i  9   j 10 \
        k 11   l 12   m 13   n 14   o 15 \
        p 16   q 17   r 18   s 19   t 20 \
        u 21   v 22   w 23   x 24   y 25 \
        z 26                             \
                         \
         1 a    2 b    3 c    4 d    5 e \
         6 f    7 g    8 h    9 i   10 j \
        11 k   12 l   13 m   14 n   15 o \
        16 p   17 q   18 r   19 s   20 t \
        21 u   22 v   23 w   24 x   25 y \
        26 z]
 
    set re_syntax {^(([0-9]+-[0-9]+)|([A-Z]-[A-Z])|([a-z]-[a-z]))$}
    set res {}
    foreach i $clist {
        if {[regexp $re_syntax $i -> range a b c]} {
            set range [split $range -]
            set start [lindex $range 0]
            set stop  [lindex $range 1]
            switch -- [expr {($a!="")?1:($b!="")?2:($c!="")?3:4}] {
                1 {
                    for {set j $start} {$j <= $stop} {incr j} {
                        lappend res $j
                    }
                }
                2 {
                    set j $map([string tolower $start])
                    for {} {$j <= $map([string tolower $stop])} {incr j} {
                        lappend res [string toupper $map($j)]
                    }
                }
                3 {
                    for {set j $map($start)} {$j <= $map($stop)} {incr j} {
                        lappend res $map($j)
                    }
                }
            }
        }       else {lappend res $i}
    }; return $res
} ;# Carl M. Gregory, MC_8 -- http://mc.purehype.net/

Country name server

CH <-> Switzerland.. see Language/Country name servers

Credit card check digit validation

see Validating credit card check digits

Cross sum of a digit sequence

see Additional math functions

csv strings

comma-separated values, as exported e.g. by Excel, see Parsing csv strings

Date scanning

clock scan older versions (pre 8.3?) did not handle the frequent (ISO-standardized) format YYYY-MM-DD hh:mm:ss. Here's a workaround by Hume Smith to be used in the place of clock scan for such cases:

proc yyyy-mm-dd {dtstring} {
    set time {} ;# this allows pure dates without time
    scan $dtstring %d-%d-%d%s year month day time
    clock scan "$month/$day/$year $time"
} ;# RS

and another by Bruce Gingery:

proc YYYYMMDD2MDY {dtstring} {
    set patt {^[1-2][0-9]([0-9][0-9])-([0-9][0-9]?)-([0-9][0-9]?)}
    set subs {\2/\3/\1}
    regsub $patt $dtstring $subs dtstring
    return $dtstring
# or return [clock scan $dtstring]
}

Date and Time in a Handy Format

like 22.07.99,19:59:00

proc date,time {{when ""}} {
      if {$when == ""} {set when [clock seconds]}
      clock format $when -format "%d.%m.%y,%H:%M:%S"
} ;#RS

Debugging Aid For Production Code

-PSE

Disk free capacity

in Kilobytes:

proc df-k {{dir .}} {
    switch $::tcl_platform(os) {
    FreeBSD -
    Linux -
    OSF1 -
    SunOS {
        # Use end-2 instead of 3 because long mountpoints can 
        # make the output to appear in two lines. There is df -k -P
        # to avoid this, but -P is Linux specific afaict
        lindex [lindex [split [exec df -k $dir] \n] end] end-2
    }
    HP-UX {lindex [lindex [split [exec bdf   $dir] \n] end] 3}
    {Windows NT} {
        expr [lindex [lindex [split [exec cmd /c dir /-c $dir] \n] end] 0]/1024
            # CL notes that, someday when we want a bit more
            #    sophistication in this region, we can try
            #    something like
            #       secpercluster,bytespersector, \
            #       freeclusters,noclusters = \
            #            win32api.GetDiskFreeSpace(drive)
            #    Then multiply long(freeclusters), secpercluster,
            #    and bytespersector to get a total number of
            #    effective free bytes for the drive.
            # CL further notes that
            #http://developer.apple.com/techpubs/mac/Files/Files-96.html
            #    explains use of PBHGetVInfo() to do something analogous
            #    for MacOS.
        }
    default {error "don't know how to df-k on $::tcl_platform(os)"}
    }
} ;#RS

for Win9x replace cmd with command. Note that W98(SE)? may report as Windows 95. So,

   {Windows 95} {
        expr [lindex [lindex [split [exec command /c dir /-c $dir] \n] end] 0]/1024
   }

Every time df comes up in clt, I think I should write one that works for us *poor souls* who are stuck in the world of win9x. So the other night...:


proc free_win { } {
    set res [eval exec [auto_execok dir]]
    set var [expr [llength $res] -3]
    set free_space [lrange $res $var end]
    return $free_space
}

This works on win95, 98 and NT, with tcl/tk 8.0 through 8.4a2. If anybody tests it with win2000 or ME, please let us know the result.

so 04/20/01

do ... while

See also do...until in Tcl

do ... while loop structure, as in C

loop structure. By Morten Skaarup Jensen

proc do {cmds while expr} {
    uplevel  $cmds
    uplevel "while [list $expr] [list $cmds]"
}
# Example of use
set x 0
do {
    puts $x
    incr $x
} while {$x < 10}

This doesn't work 100% with breaks. Catch might be the best way to improve this.

Drive letters

on Windows -- "file volumes" lists drives even if there's no medium in it. mailto:[email protected] contributed this code to list mapped and existing drives:

proc drives {} {
    foreach drive [list a b c d e f g h i j k l m n o p q r s t u v x y z] {
        if {[catch {file stat ${drive}: dummy}] == 0} {
            lappend drives $drive
        }
    }
    return $drives
}

English number speller

e.g. en:num 29 => twenty-nine, see Bag of number/time spellers

Executable scripts

Tcl scripts with initial magic can be called directly from a shell prompt. In UNIX, you can specify the path to tclsh (or wish, as you wish) in a special comment line, e.g.

 #!/tools/bin/tclsh

but this requires adaptation to the local situation. More flexible is the following, which finds the way itself:

 #!/bin/sh
 # the next line restarts using -*-Tcl-*-sh \
 exec tclsh "$0" ${1+"$@"}

Tom Tromey explains the ${1+"$@"} bit in exec magic

The -*- stuff instructs emacs to treat this file in Tcl mode. In both cases, do a chmod +x filename for real availability.

For Win95, Rolf Schroedter reports the following to work: file foo.bat:

        ::set run_dos { ;# run tcl-script from BAT-file
        tclsh80 %0 %1 %2 %3 %4 %5 %6 %7 %8 %9
        exit
        }
        puts "Tcl $tcl_patchLevel"

Small addition: This has at least on NT the problem, that, when started from a CMD.EXE window that this window gets closed on the "exit" call. I cannot find any command to just terminate the running script, so I use:

        ::set run_dos { ;# run tcl-script from BAT-file
        tclsh80 %0 %1 %2 %3 %4 %5 %6 %7 %8 %9
        goto EOF
        }

        # your TCL code goes here
        # ...
        ::set run_dos \
       :EOF

Might get a problem if ":EOF" is a valid Proc in your program and gets called in the main program, though. - Michael Teske

This works for me on NT:

        ::set run_dos {
                @tclsh %~f0 %*
                exit /b
        }

It has the added advantage that all command line arguments are given to tclsh ("%*") and that the tclsh gets the full path of the file to start ("%~f0") - Klaus Marius Hansen - See also DOS BAT magic

environment variables

What are the values of my environment variables? I use this in a wish shell while writing programs in other languages.

foreach e [lsort [array names env]] { puts "$e = $env($e)" }

expr

Files and sockets in use

For Tcl 8.4 the file channels builtin command does this.

by Phil Ehrens <[email protected]>

UNIX only

proc countFilehandles {{limit 1024}} {
    set i 0; set socks {}; set files {}
    while {$i < $limit} {
        if ![catch {tell sock$i}] {lappend socks sock$i}
        if ![catch {tell file$i}] {lappend files file$i}
        incr i
    }
    return [list $socks $files]
}

Fraction Math

See Fraction Math -- kbk [L2 ]

2.75 <-> 2-3/4. Not exact, resolution can be specified (default 1/8)

proc fracn2num {args} {
    if ![regexp {(([0-9]+)[ -])?([0-9]+)/([0-9]+)} $args -> - int num den] {
        return $args
    }
    expr $int+double($num)/$den
}
proc num2fracn {n {r 8}} {
    if [set in [expr int($n)]]==$n {return $n}
    if $in {set res $in-} else {set res {}}
    return $res[join [simplify [expr int(round(($n-$in)*$r))] $r] /]
}
proc simplify {p q} {
    set g [gcd $p $q]
    list [expr $p/$g] [expr $q/$g]
} ;#RS (frac2num handling for things like '2 3/4' added by PSE)

offers some advances on the ''Fraction math' section.

freeMem: Freeing memory the Tcl way!

Permits evaluation of code in a manner which does NOT cause the interpreter to permanently allocate heaps of heap.

IEEE binary float to string conversion

Integer Check

See Additional math functions

Integer maximum

see Additional math functions

Integer width

in bits (by Jeffrey Hobbs):

proc int_bits {} {
    set int 1
    set exp 8; # Assuming a minimum of 8 bits
    while {$int > 0} { set int [expr {1 << [incr exp 8]}] }; # Increment in steps of 8 as integer length format is 8 bits, 16 bits, 32 bits, ....
    return $exp
}

Interrupting loops: how to introduce a "stop button" for runaway code

intgen: unique integer ID generator, at first call gives 1, then 2, 3, ...

Note how the proc rewrites its own seed default, so no global variable is needed:

proc intgen {{seed 0}} {
    proc intgen "{seed [incr seed]}" [info body intgen]
    set seed
} ;# RS

number speller, French

fr:num 99 => quatrevingt dix-neuf

see Bag of number/time spellers

German number speller

see Bag of number/time spellers

time speller, German

converts exact HH:MM times to fuzzy colloquial wording, optional Northern (viertel vor vier) or Southern style (dreiviertel vier) ;-)

see Bag of number/time spellers

money amount speller, Russian

see Bag of number/time spellers

getPid

map pids to prog names and vice-versa

gifBalls

Globbing globals

Want to import several globals in one go, with glob wildcards (similar to the public statement in VB)? This comes from David Cuthbert (mailto:[email protected] ):

proc globalpat {args} {
    foreach pattern $args {
        set varnames [info globals $pattern]
        if {[llength $varnames] != 0} {
            uplevel 1 global $varnames
        }
    }
}

To use:

proc hello {} {
    globalpat *tcl*
    puts $tcl_patchLevel
}

% hello
8.2.2

GPS/UTC Time Conversion Functions

Tcl implementation of Simpson's Rule numerical integration.

Greeklish

turns a strict ASCII transliteration into Greek Unicodes

Greatest common denominator

now on its own page

Heblish

turns a strict ASCII transliteration into Hebrew Unicodes.

hotgrep

it beats as it sweeps as it cleans!

integrate

IP address: find out your own. This beauty came from [email protected]

(note that xxx should be the name of a procedure which never gets called, so need not exist ;-):

[ip:adr used to be here.]

Many Tcl programmers wonder how to find my own IP address.

jpeg: Reading JPEG image dimensions

Language name server, zh <-> Chinese ... see Language/Country name servers

Line Counting see Counting a million lines

List Frequency Counts

see Counting Elements in a List

List spread to scalar vars, e.g. lspread {1 2 3} to a b {c 0}

proc lspread {list "to" args} {
    foreach a $args v $list {
        upvar [lindex $a 0] var ;# name maybe in list with default
        if {$v==""} {set var [lindex $a 1]} else {set var $v}
    }
} ;#RS

List well-formedness: check a string whether it could be parsed into a list (braces balanced, whitespace after closing braces)

joint effort by Bob Techentin and Donald Porter in news:comp.lang.tcl :

proc islist {s} {
    expr ![catch {eval list $s}]
} ;# RS

Hmmm... let's think twice about this one. We want to test the list well-formedness of an unknown string, so we probably don't know much about $s. It's dangerous to [eval] something you don't know. Consider this:

set s {a; file delete -force ~}
islist $s    ;# Hope you have backups!

Try this instead:

proc islist {s} {expr ![catch {llength $s}]} ;# DGP

Indeed. The former returns bad values for most things containing '$', or [,] etc. The latter does what you want.

List with duplicates removed, and keeping the original order:

proc luniq {L} {
    # removes duplicates without sorting the input list
    set t [list]
    foreach i $L {if {[lsearch -exact $t $i]==-1} {lappend t $i}}
    return $t
} ;# RS
proc lun {L} {
    set t [list]
    foreach i $L {if { $i ni $t } { lappend t $i }}
    return $t
} ;# EE

ls -l in Tcl

ls: make glob look more like the Unix thing

proc ls {{fn *}} {
    lsort [glob -nocomplain $fn .$fn]
} ;#RS

Also see ls -l in Tcl....

Mail sender (minimalist, Unix only):

proc mailto {name subj text} {
    set f [open "|mail $name" w]
    puts  $f "Subject: $subj\n\n$text"
    close $f
}

Cf. http://www.phaseit.net/claird/comp.lang.tcl/tcl-examples.html#mail

using tcllib: PT

 package require mime
 package require smtp

 set tok [mime::initialize -canonical text/plain -string "Hello, World!"]
 smtp::sendmessage $tok \
    -header {From "[email protected]"} \
    -header {To "You <[email protected]>"} \
    -header {Subject "Simple Tcllib mailing."}
 mime::finalize $tok

Mail checker, even more minimalist, Unix only:

proc haveMail {} {
    expr [file size /var/mail/$::env(USER)]>0
}

yet another Tcl mail handler! (for UNIX)

map - the traditional list functional that applies an operation to every member of a list.

proc map {command list} {
    set res [list]
    foreach item $list {
        lappend res [uplevel 1 [concat $command [list $item]]]
    }
    set res
}

See also Steps towards functional programming for related discussions.

Maximum and minimum Everybody writes them himself, here's mine:

see Additional math functions

Morse en/decoder: works both ways ASCII <-> Morse, see Bag of number/time spellers ''-

yah, well, it has to go somewhere... JC''

N-gram frequency counts, see tally: a string counter gadget

Namespace variables listed local names of variables as defined in a namespace:

proc nsvars {ns} {
    regsub -all ::${ns}:: [info vars ${ns}::*] "" res
    set res
}  ;# RS

alternatively (requires map operator from elsewhere on this page) - DKF

proc nsvars {{ns {}}} {
    map [list namespace tail] [info vars ${ns}::*]
}

NUKE: delete a file when its descriptor is closed:

proc NUKE { filename fid } {
     if { ! [ llength [ file channels $fid ] ] } {
         file delete $filename
     } else {
         after 1000 "NUKE $filename $fid"
     }
}

DKF - Alternatively, rewrite the close and exit commands...

rename close orig_close_NUKE
rename exit orig_exit_NUKE
proc close {fid} {
    global NUKE errorInfo errorCode
    set code [catch {orig_close_NUKE $fid} msg]
    set ei $errorInfo
    set ec $errorCode
    if {[info exist NUKE($fid)]} {
        file delete $NUKE($fid)
        unset NUKE($fid)
    }
    return -code $code -errorinfo $ei -errorcode $ec $msg
}

proc exit {{code 0}} {
    global NUKE
    foreach fid [array names NUKE] {catch {close $fid}}
    orig_exit_NUKE $code
}

proc NUKE {filename fid} {
    global NUKE
    set NUKE($fid) $filename
}

proc tmpfile {{tmpdir /tmp}} {
    global SEQID; if {![info exist SEQID]} {set SEQID 0}
    set basename [file rootname [file tail $::argv0]]
    set filename [file join $tmpdir ${basename}.[pid].[incr SEQID].tmp]
    set fid [open $filename w+]
    NUKE $filename $fid
    return $fid
}

Number commified (added culture-dependent thousands mark):

proc number_commify {n {sign ,}} {
    # structure a decimal like 123,456.78 123'456.78, or 123.456,78
    if {$sign=="."} {regsub {[.]} $n "," n}
    set trg "\\1$sign\\2"
    while {[regsub {^ *([-+]?[0-9]+)([0-9][0-9][0-9])} $n $trg n]} {}
    return $n
} ;# added " *" to regexp, so leading blanks as from format work - RS

A one-liner alternative by Peter Spjuth (in the Tcl chatroom, 2004-10-05) uses modern regexp features:

proc commify number {
    regsub -all {\d(?=(\d{3})+($|\.))} $number {\0,}
}

See also Human readable file size formatting

Option Parser: expandOpts

proc Instrumentation

You can add code to every procedure in your Tcl application by redefining the proc command to include special code. Then each proc definition will include your code. This is commonly done for debuggers and profilers. For example, if you wanted to count each time your procedures are called, you could include code like this example, courtesy of Bryan Oakly on comp.lang.tcl.

rename proc _proc
_proc proc {name arglist body} {
    set body "incr ::proc_counter($name)\n$body"
    set ::proc_counter($name) 0
    uplevel [list _proc $name $arglist $body]
}

See also Printing proc sequence.

proc validity in context: validProc

returns 1 if the procedure name or wildcard pattern exists in the current context (including all child namespaces), returns 0 if it does not. Sort of a [info commands]

for heavy namespace users.

Proc name: know your own

this one-liner wraps introspection. Useful for generated widget handlers, whose name is like the widget pathname, so they know what their widget is called:

proc proc_name {} {
    lindex [info level -1] 0
} ;#RS

Railway vehicle number validation: UIC vehicle number validator

Random Numbers

see Additional math functions

Random selection from a list

proc random_select list {
    lindex $list [expr int(rand()*[llength $list])]
} ;#RS

Roman Numbers

Bag of number/time spellers

SCCS control string bypass

When you ckeck in a file with SCCS, certain strings in the file are replaced, e.g. %H% with the current date, %M% with the current filename. This can cause problems if your code contains e.g. set now clock format [clock seconds -format %y%m%d-%H%M%S] but you can hide percent signs by replacing them with the equivalent \x25, so SCCS doesn't see them but the Tcl parser does (RS)

set now [clock format [clock seconds] -format %y%m%d-\x25H\x25M\x25S]

Here's my method - use append to build up the string:

append datestring %y %m %d - %H %M %S
set now [clock format [clock seconds] -format %datestring]

Marty Backe

Self-test code

See main script.

Set operations: A set of Set operations

Shuffle a list -- various ways of permuting a list into (pseudo-)random sequence.

Silly Asynchronous Event Example

# initialise our trigger variable
set foo {}

# a proc to call when the trigger variable is written
proc bye {args} { exit }

# some code to push into the event loop for 0.5 sec
# that produces visible output, and writes the trigger var
after 500 {
   puts "what a question!"
   set foo {}
}

# some other code that gets pushed into the loop for 0.2 sec
after 200 {
    puts "where did I come from?"
}

# some code that is executed immediately
puts "and then he asked:"

# set a trace on "foo", so that when it is written the
# procedure "bye" is called
trace variable foo w bye

# initiate an event loop (this is what "wish" does)
vwait enter-mainloop

(DKF: And this is supposed to be a good feature of Tcl? Hmmm...)

Simple Arbitrary Precision Math Procedures -- DKF

Size of running Tcl process (Unix only)

sleep

unix-like

Sort on String Length / Password Generator

proc {lengthCompare} {w1 w2} {
    set sl1 [string length $w1]
    set sl2 [string length $w2]
    if {$sl1 > $sl2} {
        return 1
    } elseif {$sl1 == $sl2} {
        return 0
    } else {
        return -1
    }
}

set data {asdf asdfasdf asdfa asd asdfasd}
# The following will sort the command by String Length
set data [lsort -command lengthCompare $data]

# More info -
# The following makes a password out of the data by using
# the word alone if it is 5 chars or more, (eg asdfasd)
# and by finding a match for it if it is less (eg asd-asdf)
# than 5 chars.  The password can be max of 8 chars in
# this example.

# This was used on a stripped-down version of the words
# file for the UNIX spell checker to generate random
# passwords.

set datalength [llength $data]

set word1 [lindex $data [expr {int([expr {rand()*$datalength}])}]]
set w1l [string length $word1]

if {$w1l < 5} {
    set pos [expr {int([expr {rand()*$datalength}])}]
    # This speedily decrements the random number generated
    # until the size is small enough to fit in an 8 char
    # field.
    while {[expr {8-$w1l-[string length [lindex $data $pos]]}] < 1} {
        set pos [expr {int([expr {rand()*$pos}])}]
    }
    set word2 [lindex $data $pos]
    append word1 "-$word2"
    set word1 "$word1"
}

# Output the password
puts "${word1}\n"

String to list

collapsing splitchar sequences

soundex

Splitting strings into words

Stack operations on lists: lpush prepends, lpop removes first element.

lpop and lappend make a FIFO queue.

proc lpush {_list what} {
   upvar $_list L
   if ![info exists L] {set L {}}
   set L [concat [list $what] $L]
}
proc lpop {_list} {
   upvar $_list L
   if ![info exists L] {return ""}
   set t [lindex $L 0]
   set L [lrange $L 1 end]
   return $t
} ;#RS

also see: yet another stack package and the Chart of proposed list functionality

Stack trace: just sprinkle a few of these "probes" around to see the stack at that point

shamelessly swiped from Cameron Laird

proc probe {} {
    puts "Stack trace:"
    for {set i [expr [info level] - 1]} {$i} {incr i -1} {
        puts "  Processing '[info level $i]'."
    }
} ;# JCW

For more on this subject, see "Printing proc sequence".

Stats

simple statistical functions (mean, stddev, cov)

String to list

[split $s] alone operates on each instance of the splitchar (default:space), so sequences of spaces will produce empty list elements.

[eval list $s] collapses whitespace sequences in one, but errors on unbalanced braces etc. The following proc should join the best of both worlds:

proc string2list s {
    if [catch {eval list $s} res] {
        set res [list]
        foreach i [split $s] {
            if {$i!=""} {lappend res $i}
        }
    }
    set res
} ;#RS
% string2list {a   b c     d}
a b c d
% string2list "a   b c  {"
a b c \{
% string2list {unbalanced "}
unbalanced {"}

Note that this suffers from the same dangers as explained in the List well-formedness test above. Modifications for safety are left as an exercise for the reader (or the next Wiki visitor). You have been warned. - DGP

EE: This seems as good a place as any to ask this question... Is there any effective difference, in general, between catch {eval command $args} and catch [linsert $args 0 command] ?

Yes: The latter is more efficient. See pure list and many ways to eval for discussion.

DGP: Yes, see those pages, but efficiency differences are not the main point. Those two examples will process newlines in the arguments differently. Newlines are significant to eval but not necessarily preserved by list-processing commands.

Swap 2 values efficiently

Swaps value of a with b without overhead of copying to a temporary variable:

foreach {a b} [list $b $a] break

Works for a and b as numbers, strings and lists but not arrays.

AMG: Here's a faster method that works using Tcl 8.5+.

lassign [list $b $a] a b

On my machine, [lassign] takes 3.2239 microseconds per iteration, whereas [foreach] takes 8.562 microseconds per iteration.

subcommands: value-added switch, FREE error message ;-)

Tabs to spaces, and back: courtesy Jeffrey Hobbs

# untabify --
#   removes tabs from a string, replacing with appropriate number of
#   spaces. Arguments:
#   str         input string
#   tablen      tab length, defaults to 8
# Returns:
#   string sans tabs
#
proc untabify {str {tablen 8}} {
    set out {}
    while {[set i [string first "\t" $str]] != -1} {
        set j [expr {$tablen-($i%$tablen)}]
        append out [string range $str 0 [incr i -1]][format %*s $j { }]
        set str [string range $str [incr i 2] end]
    }
    return $out$str
}
# tabify --
#   converts excess spaces to tab chars. Arguments:
#   str         input string
#   tablen      tab length, defaults to 8
# Returns:
#   string with tabs replacing excess space where appropriate
#
proc tabify {str {tablen 8}} {
    ## We must first untabify so that \t is not interpreted to be 1 char
    set str [untabify $str]
    set out {}
    while {[set i [string first { } $str]] != -1} {
        ## Align i to the upper tablen boundary
        set i [expr {$i+$tablen-($i%$tablen)-1}]
        set s [string range $str 0 $i]
        if {[string match {* } $s]} {
            append out [string trimright $s { }]\t
        } else {
            append out $s
        }
        set str [string range $str [incr i] end]
    }
    return $out$str
}

AMG: The above [untabify] does not handle newlines. They are treated like any other character and do not reset the column count. If newlines can show up in the input, try this instead:

proc tabsToSpaces {str {tabStop 8}} {
    set result {}
    set newline {}
    foreach line [split $str \n] {
        set out {}
        while {[set i [string first \t $line]] != -1} {
            set j [expr {$tabStop - ($i % $tabStop)}]
            append out [string range $line 0 [incr i -1]][format %*s $j " "]
            set line [string range $line [incr i 2] end]
        }
        append result $newline $out $line
        set newline \n
    }
    return $result
}

tailf tail -f piped to egrep, in pure tcl

try ... finally ...

telnet

Sort of

client and server... but not exactly as in RFC854.

timers.tcl - benchmarking/timing package

UIC vehicle number validator - as used on European railways

Unit converter -- Does km/h <-> mph, DM <-> EUR, C <-> F ...

URI detector for arbitrary text as a regular expression

UTC -- see GPS/UTC Time Conversion Functions

Validating credit card check digits

Visual Studio 2003 .sln file parser

Word frequency counts, see tally: a string counter gadget

Plain string substitution

Prior to version 8.1.1, the only string substitution facility in the Tcl core uses regular expressions, which for substituting special text can be a pain. Here's a procedure to do a plain substition (with no extra features). See "string map" in newer versions.

proc plainsub {text item replacewith} {
    set len [expr [string length $item]-1]
    while {[set pos [string first $item $text]] != -1} {
        set text [string replace $text $pos [expr $pos+$len] $replacewith]
    }
    return $text
} ;#FW

RS What's bad with the following?

set text [string map [list $item $replacewith] $text]

FW Nothing, I'm pretty much just starting out coding, for a second there I thought I'd made something useful ;) CL interrupts: Nah, the correct answer is that Richard's set text ..." is bad because "string map ..." only appeared with 8.1.1.

As bad things go, that's only a tiny badness.

Split on Punctuation

FW: breaks a line of text into an alternating list of words and punctuation.

For example:

 (bin) 8 % break_text "A sentence, merely.  Move along."
 A { } sentence {, } merely {.  } Move { } along .

This would be used for most any language processing task, where you would break a sentence into words, perform operations on the words, then put it back together. Here it is:

proc break_text {text {splitchars {, .";!:}}} {
    # Escape all the split characters so brackets, ^ etc. will be accepted.
    set regexp "\[\\[join [split $splitchars ""] \\]\]+|$"
  set wp [list]
  set pos 0
  for {set pos 0} {$pos < [string length $text] && [regexp -indices -start $pos $regexp $text matches]}
      {set pos [expr {[lindex $matches 1] + 1}]} {

    lappend wp \
      [string range $text $pos [expr {[lindex $matches 0] - 1}]] \
      [eval string range [list $text] $matches]
  }
  return $wp
}

update: Now you can break by a character set of your choice by the optional second argument. And returns a flat list rather than a list of lists, for better use by foreach, etc.

Sample Math Programs